diff options
author | Simon Peyton Jones <simonpj@microsoft.com> | 2017-08-30 08:57:40 +0100 |
---|---|---|
committer | Simon Peyton Jones <simonpj@microsoft.com> | 2017-08-31 08:16:58 +0100 |
commit | 805b29bb873c792ca5bcbd5540026848f9f11a8d (patch) | |
tree | 993291054fd388c0e493d11175ec27922d61bb1f | |
parent | fca196280d38d07a697fbccdd8527821206b33eb (diff) | |
download | haskell-805b29bb873c792ca5bcbd5540026848f9f11a8d.tar.gz |
Add debugPprType
We pretty-print a type by converting it to an IfaceType and
pretty-printing that. But
(a) that's a bit indirect, and
(b) delibrately loses information about (e.g.) the kind
on the /occurrences/ of a type variable
So this patch implements debugPprType, which pretty prints
the type directly, with no fancy formatting. It's just used
for debugging.
I took the opportunity to refactor the debug-pretty-printing
machinery a little. In particular, define these functions
and use them:
ifPprDeubug :: SDoc -> SDOc -> SDoc
-- Says what to do with and without -dppr-debug
whenPprDebug :: SDoc -> SDoc
-- Says what to do with -dppr-debug; without is empty
getPprDebug :: (Bool -> SDoc) -> SDoc
getPprDebug used to be called sdocPprDebugWith
whenPprDebug used to be called ifPprDebug
So a lot of files get touched in a very mechanical way
32 files changed, 154 insertions, 98 deletions
diff --git a/compiler/basicTypes/BasicTypes.hs b/compiler/basicTypes/BasicTypes.hs index 90a043de76..c6ffaad0d4 100644 --- a/compiler/basicTypes/BasicTypes.hs +++ b/compiler/basicTypes/BasicTypes.hs @@ -789,9 +789,8 @@ tupleParens :: TupleSort -> SDoc -> SDoc tupleParens BoxedTuple p = parens p tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) - = sdocWithPprDebug $ \dbg -> if dbg - then text "(%" <+> p <+> ptext (sLit "%)") - else parens p + = ifPprDebug (text "(%" <+> p <+> ptext (sLit "%)")) + (parens p) {- ************************************************************************ diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs index f28ae011ac..5f496059d2 100644 --- a/compiler/basicTypes/RdrName.hs +++ b/compiler/basicTypes/RdrName.hs @@ -1237,9 +1237,8 @@ pprNameProvenance :: GlobalRdrElt -> SDoc -- ^ Print out one place where the name was define/imported -- (With -dppr-debug, print them all) pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) - = sdocWithPprDebug $ \dbg -> if dbg - then vcat pp_provs - else head pp_provs + = ifPprDebug (vcat pp_provs) + (head pp_provs) where pp_provs = pp_lcl ++ map pp_is iss pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] diff --git a/compiler/basicTypes/SrcLoc.hs b/compiler/basicTypes/SrcLoc.hs index 1e6e7d2535..3d3db956d7 100644 --- a/compiler/basicTypes/SrcLoc.hs +++ b/compiler/basicTypes/SrcLoc.hs @@ -548,7 +548,7 @@ instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where -- GenLocated: -- Print spans without the file name etc -- ifPprDebug (braces (pprUserSpan False l)) - ifPprDebug (braces (ppr l)) + whenPprDebug (braces (ppr l)) $$ ppr e {- diff --git a/compiler/coreSyn/CoreLint.hs b/compiler/coreSyn/CoreLint.hs index 7878e62c5d..92c14bc871 100644 --- a/compiler/coreSyn/CoreLint.hs +++ b/compiler/coreSyn/CoreLint.hs @@ -2021,10 +2021,9 @@ addMsg env msgs msg locs = le_loc env (loc, cxt1) = dumpLoc (head locs) cxts = [snd (dumpLoc loc) | loc <- locs] - context = sdocWithPprDebug $ \dbg -> if dbg - then vcat (reverse cxts) $$ cxt1 $$ - text "Substitution:" <+> ppr (le_subst env) - else cxt1 + context = ifPprDebug (vcat (reverse cxts) $$ cxt1 $$ + text "Substitution:" <+> ppr (le_subst env)) + cxt1 mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg) diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs index 1ac3084e39..73a15c318f 100644 --- a/compiler/coreSyn/PprCore.hs +++ b/compiler/coreSyn/PprCore.hs @@ -213,7 +213,7 @@ ppr_expr add_par (Case expr var ty [(con,args,rhs)]) ] else add_par $ sep [sep [sep [ text "case" <+> pprCoreExpr expr - , ifPprDebug (text "return" <+> ppr ty) + , whenPprDebug (text "return" <+> ppr ty) , text "of" <+> ppr_bndr var ] , char '{' <+> ppr_case_pat con args <+> arrow @@ -228,7 +228,7 @@ ppr_expr add_par (Case expr var ty alts) = add_par $ sep [sep [text "case" <+> pprCoreExpr expr - <+> ifPprDebug (text "return" <+> ppr ty), + <+> whenPprDebug (text "return" <+> ppr ty), text "of" <+> ppr_bndr var <+> char '{'], nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), char '}' diff --git a/compiler/deSugar/Desugar.hs b/compiler/deSugar/Desugar.hs index 4bfd10f2ef..fbb6386c60 100644 --- a/compiler/deSugar/Desugar.hs +++ b/compiler/deSugar/Desugar.hs @@ -435,7 +435,7 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids <+> text "might inline first") , text "Probable fix: add an INLINE[n] or NOINLINE[n] pragma for" <+> quotes (ppr lhs_id) - , ifPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) + , whenPprDebug (ppr (idInlineActivation lhs_id) $$ ppr rule_act) ]) | check_rules_too , bad_rule : _ <- get_bad_rules lhs_id @@ -446,7 +446,7 @@ warnRuleShadowing rule_name rule_act fn_id arg_ids <+> text "for"<+> quotes (ppr lhs_id) <+> text "might fire first") , text "Probable fix: add phase [n] or [~n] to the competing rule" - , ifPprDebug (ppr bad_rule) ]) + , whenPprDebug (ppr bad_rule) ]) | otherwise = return () diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs index 263aeba7e9..b269f33a1c 100644 --- a/compiler/ghci/RtClosureInspect.hs +++ b/compiler/ghci/RtClosureInspect.hs @@ -338,22 +338,22 @@ ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do return $ cparen (not (null tt) && p >= app_prec) (text dc_tag <+> pprDeeperList fsep tt_docs) -ppr_termM y p Term{dc=Right dc, subTerms=tt} = do +ppr_termM y p Term{dc=Right dc, subTerms=tt} {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) <+> hsep (map (ppr_term1 True) tt) -} -- TODO Printing infix constructors properly - tt_docs' <- mapM (y app_prec) tt - return $ sdocWithPprDebug $ \dbg -> - -- Don't show the dictionary arguments to - -- constructors unless -dppr-debug is on - let tt_docs = if dbg - then tt_docs' - else dropList (dataConTheta dc) tt_docs' - in if null tt_docs - then ppr dc - else cparen (p >= app_prec) $ - sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] + = do { tt_docs' <- mapM (y app_prec) tt + ; return $ ifPprDebug (show_tm tt_docs') + (show_tm (dropList (dataConTheta dc) tt_docs')) + -- Don't show the dictionary arguments to + -- constructors unless -dppr-debug is on + } + where + show_tm tt_docs + | null tt_docs = ppr dc + | otherwise = cparen (p >= app_prec) $ + sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t ppr_termM y p RefWrap{wrapped_term=t} = do @@ -371,7 +371,7 @@ ppr_termM1 :: Monad m => Term -> m SDoc ppr_termM1 Prim{value=words, ty=ty} = return $ repPrim (tyConAppTyCon ty) words ppr_termM1 Suspension{ty=ty, bound_to=Nothing} = - return (char '_' <+> ifPprDebug (text "::" <> ppr ty)) + return (char '_' <+> whenPprDebug (text "::" <> ppr ty)) ppr_termM1 Suspension{ty=ty, bound_to=Just n} -- | Just _ <- splitFunTy_maybe ty = return$ ptext (sLit("<function>") | otherwise = return$ parens$ ppr n <> text "::" <> ppr ty diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs index a8efa7206f..85c002b481 100644 --- a/compiler/hsSyn/HsBinds.hs +++ b/compiler/hsSyn/HsBinds.hs @@ -675,9 +675,9 @@ ppr_monobind (FunBind { fun_id = fun, fun_tick = ticks }) = pprTicks empty (if null ticks then empty else text "-- ticks = " <> ppr ticks) - $$ ifPprDebug (pprBndr LetBind (unLoc fun)) + $$ whenPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind matches - $$ ifPprDebug (ppr wrap) + $$ whenPprDebug (ppr wrap) ppr_monobind (PatSynBind psb) = ppr psb ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars , abs_exports = exports, abs_binds = val_binds @@ -778,7 +778,7 @@ deriving instance (DataId name) => Data (IPBind name) instance (SourceTextX p, OutputableBndrId p) => Outputable (HsIPBinds p) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) - $$ ifPprDebug (ppr ds) + $$ whenPprDebug (ppr ds) instance (SourceTextX p, OutputableBndrId p ) => Outputable (IPBind p) where ppr (IPBind lr rhs) = name <+> equals <+> pprExpr (unLoc rhs) diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs index 03df7ccade..2186a728f2 100644 --- a/compiler/hsSyn/HsExpr.hs +++ b/compiler/hsSyn/HsExpr.hs @@ -1944,7 +1944,7 @@ pprStmt :: forall idL idR body . (SourceTextX idL, SourceTextX idR, Outputable body) => (StmtLR idL idR body) -> SDoc pprStmt (LastStmt expr ret_stripped _) - = ifPprDebug (text "[last]") <+> + = whenPprDebug (text "[last]") <+> (if ret_stripped then text "return" else empty) <+> ppr expr pprStmt (BindStmt pat expr _ _ _) = hsep [ppr pat, larrow, ppr expr] @@ -1959,7 +1959,7 @@ pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , recS_later_ids = later_ids }) = text "rec" <+> vcat [ ppr_do_stmts segment - , ifPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids + , whenPprDebug (vcat [ text "rec_ids=" <> ppr rec_ids , text "later_ids=" <> ppr later_ids])] pprStmt (ApplicativeStmt args mb_join _) @@ -2007,7 +2007,7 @@ pprStmt (ApplicativeStmt args mb_join _) pprTransformStmt :: (SourceTextX p, OutputableBndrId p) => [IdP p] -> LHsExpr p -> Maybe (LHsExpr p) -> SDoc pprTransformStmt bndrs using by - = sep [ text "then" <+> ifPprDebug (braces (ppr bndrs)) + = sep [ text "then" <+> whenPprDebug (braces (ppr bndrs)) , nest 2 (ppr using) , nest 2 (pprBy by)] @@ -2263,14 +2263,14 @@ pprSplice (HsQuasiQuote n q _ s) = ppr_quasi n q s pprSplice (HsSpliced _ thing) = ppr thing ppr_quasi :: OutputableBndr p => p -> p -> FastString -> SDoc -ppr_quasi n quoter quote = ifPprDebug (brackets (ppr n)) <> +ppr_quasi n quoter quote = whenPprDebug (brackets (ppr n)) <> char '[' <> ppr quoter <> vbar <> ppr quote <> text "|]" ppr_splice :: (SourceTextX p, OutputableBndrId p) => SDoc -> (IdP p) -> LHsExpr p -> SDoc -> SDoc ppr_splice herald n e trail - = herald <> ifPprDebug (brackets (ppr n)) <> ppr e <> trail + = herald <> whenPprDebug (brackets (ppr n)) <> ppr e <> trail -- | Haskell Bracket data HsBracket p = ExpBr (LHsExpr p) -- [| expr |] @@ -2519,13 +2519,11 @@ pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctx -- transformed branch of -- transformed branch of monad comprehension pprStmtContext (ParStmtCtxt c) = - sdocWithPprDebug $ \dbg -> if dbg - then sep [text "parallel branch of", pprAStmtContext c] - else pprStmtContext c + ifPprDebug (sep [text "parallel branch of", pprAStmtContext c]) + (pprStmtContext c) pprStmtContext (TransStmtCtxt c) = - sdocWithPprDebug $ \dbg -> if dbg - then sep [text "transformed branch of", pprAStmtContext c] - else pprStmtContext c + ifPprDebug (sep [text "transformed branch of", pprAStmtContext c]) + (pprStmtContext c) instance (Outputable p, Outputable (NameOrRdrName p)) => Outputable (HsStmtContext p) where diff --git a/compiler/hsSyn/HsLit.hs b/compiler/hsSyn/HsLit.hs index 31c7a02d07..8995ed93b3 100644 --- a/compiler/hsSyn/HsLit.hs +++ b/compiler/hsSyn/HsLit.hs @@ -224,7 +224,7 @@ pp_st_suffix (SourceText st) suffix _ = text st <> suffix instance (SourceTextX p, OutputableBndrId p) => Outputable (HsOverLit p) where ppr (OverLit {ol_val=val, ol_witness=witness}) - = ppr val <+> (ifPprDebug (parens (pprExpr witness))) + = ppr val <+> (whenPprDebug (parens (pprExpr witness))) instance Outputable OverLitVal where ppr (HsIntegral i) = pprWithSourceText (il_text i) (integer (il_value i)) diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs index 5caf1a0f6c..bcdcca2677 100644 --- a/compiler/hsSyn/HsPat.hs +++ b/compiler/hsSyn/HsPat.hs @@ -495,7 +495,7 @@ instance (Outputable arg) ppr (HsRecFields { rec_flds = flds, rec_dotdot = Just n }) = braces (fsep (punctuate comma (map ppr (take n flds) ++ [dotdot]))) where - dotdot = text ".." <+> ifPprDebug (ppr (drop n flds)) + dotdot = text ".." <+> whenPprDebug (ppr (drop n flds)) instance (Outputable p, Outputable arg) => Outputable (HsRecField' p arg) where diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index 0e4338b8bf..47d38353f8 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -1209,8 +1209,9 @@ pprHsForAllExtra extra qtvs cxt pprHsForAllTvs :: (SourceTextX pass, OutputableBndrId pass) => [LHsTyVarBndr pass] -> SDoc -pprHsForAllTvs qtvs = sdocWithPprDebug $ \debug -> - ppWhen (debug || not (null qtvs)) $ forAllLit <+> interppSP qtvs <> dot +pprHsForAllTvs qtvs + | null qtvs = whenPprDebug (forAllLit <+> dot) + | otherwise = forAllLit <+> interppSP qtvs <> dot pprHsContext :: (SourceTextX pass, OutputableBndrId pass) => HsContext pass -> SDoc diff --git a/compiler/iface/IfaceSyn.hs b/compiler/iface/IfaceSyn.hs index 3360d742ef..13eb2089a7 100644 --- a/compiler/iface/IfaceSyn.hs +++ b/compiler/iface/IfaceSyn.hs @@ -996,7 +996,7 @@ pprIfaceConDecl ss gadt_style tycon tc_binders parent | otherwise = sep [pp_field_args, arrow <+> pp_res_ty] - ppr_bang IfNoBang = sdocWithPprDebug $ \dbg -> ppWhen dbg $ char '_' + ppr_bang IfNoBang = whenPprDebug $ char '_' ppr_bang IfStrict = char '!' ppr_bang IfUnpack = text "{-# UNPACK #-}" ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <> diff --git a/compiler/iface/IfaceType.hs b/compiler/iface/IfaceType.hs index b1ad780782..f623ca2997 100644 --- a/compiler/iface/IfaceType.hs +++ b/compiler/iface/IfaceType.hs @@ -882,7 +882,7 @@ pprTyTcApp' ctxt_prec tc tys dflags style = kindStar | otherwise - = sdocWithPprDebug $ \dbg -> + = getPprDebug $ \dbg -> if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey -- Suppress detail unles you _really_ want to see -> text "(TypeError ...)" diff --git a/compiler/iface/LoadIface.hs b/compiler/iface/LoadIface.hs index b1a3ef1e6f..01fdaacd9f 100644 --- a/compiler/iface/LoadIface.hs +++ b/compiler/iface/LoadIface.hs @@ -144,7 +144,7 @@ importDecl name { eps <- getEps ; case lookupTypeEnv (eps_PTE eps) name of Just thing -> return $ Succeeded thing - Nothing -> let doc = ifPprDebug (found_things_msg eps $$ empty) + Nothing -> let doc = whenPprDebug (found_things_msg eps $$ empty) $$ not_found_msg in return $ Failed doc }}} diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs index 3c4501f613..95f07151ce 100644 --- a/compiler/nativeGen/Dwarf/Types.hs +++ b/compiler/nativeGen/Dwarf/Types.hs @@ -344,7 +344,7 @@ pprFrameProc frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks) procEnd = mkAsmTempEndLabel procLbl ifInfo str = if hasInfo then text str else empty -- see [Note: Info Offset] - in vcat [ ifPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon + in vcat [ whenPprDebug $ text "# Unwinding for" <+> ppr procLbl <> colon , pprData4' (ppr fdeEndLabel <> char '-' <> ppr fdeLabel) , ppr fdeLabel <> colon , pprData4' (ppr frameLbl <> char '-' <> diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index fce432a3dc..936cff7837 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -516,7 +516,7 @@ pprDataItem' dflags lit asmComment :: SDoc -> SDoc -asmComment c = ifPprDebug $ text "# " <> c +asmComment c = whenPprDebug $ text "# " <> c pprInstr :: Instr -> SDoc diff --git a/compiler/prelude/ForeignCall.hs b/compiler/prelude/ForeignCall.hs index ff893ede02..bd80a36ad4 100644 --- a/compiler/prelude/ForeignCall.hs +++ b/compiler/prelude/ForeignCall.hs @@ -196,7 +196,7 @@ instance Outputable CExportSpec where instance Outputable CCallSpec where ppr (CCallSpec fun cconv safety) - = hcat [ ifPprDebug callconv, ppr_fun fun ] + = hcat [ whenPprDebug callconv, ppr_fun fun ] where callconv = text "{-" <> ppr cconv <> text "-}" diff --git a/compiler/profiling/CostCentre.hs b/compiler/profiling/CostCentre.hs index 4dd54dcc6c..e5fcf315ff 100644 --- a/compiler/profiling/CostCentre.hs +++ b/compiler/profiling/CostCentre.hs @@ -255,9 +255,9 @@ pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc cc_is_caf = caf}) = text "__scc" <+> braces (hsep [ ppr m <> char '.' <> ftext n, - ifPprDebug (ppr key), + whenPprDebug (ppr key), pp_caf caf, - ifPprDebug (ppr loc) + whenPprDebug (ppr loc) ]) pp_caf :: IsCafCC -> SDoc diff --git a/compiler/simplCore/CoreMonad.hs b/compiler/simplCore/CoreMonad.hs index 82c636c232..9198e0ca5a 100644 --- a/compiler/simplCore/CoreMonad.hs +++ b/compiler/simplCore/CoreMonad.hs @@ -253,7 +253,7 @@ bindsOnlyPass pass guts -} getVerboseSimplStats :: (Bool -> SDoc) -> SDoc -getVerboseSimplStats = sdocWithPprDebug -- For now, anyway +getVerboseSimplStats = getPprDebug -- For now, anyway zeroSimplCount :: DynFlags -> SimplCount isZeroSimplCount :: SimplCount -> Bool diff --git a/compiler/simplCore/SimplUtils.hs b/compiler/simplCore/SimplUtils.hs index 70e1134814..8365952ebb 100644 --- a/compiler/simplCore/SimplUtils.hs +++ b/compiler/simplCore/SimplUtils.hs @@ -197,7 +197,7 @@ instance Outputable SimplCont where = (text "StrictArg" <+> ppr (ai_fun ai)) $$ ppr cont ppr (Select { sc_dup = dup, sc_bndr = bndr, sc_alts = alts, sc_env = se, sc_cont = cont }) = (text "Select" <+> ppr dup <+> ppr bndr) $$ - ifPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont + whenPprDebug (nest 2 $ vcat [ppr (seTvSubst se), ppr alts]) $$ ppr cont {- Note [The hole type in ApplyToTy] diff --git a/compiler/specialise/Rules.hs b/compiler/specialise/Rules.hs index b5606754e6..a0f42cd2b5 100644 --- a/compiler/specialise/Rules.hs +++ b/compiler/specialise/Rules.hs @@ -418,14 +418,13 @@ findBest _ (rule,ans) [] = (rule,ans) findBest target (rule1,ans1) ((rule2,ans2):prs) | rule1 `isMoreSpecific` rule2 = findBest target (rule1,ans1) prs | rule2 `isMoreSpecific` rule1 = findBest target (rule2,ans2) prs - | debugIsOn = let pp_rule rule = sdocWithPprDebug $ \dbg -> if dbg - then ppr rule - else doubleQuotes (ftext (ruleName rule)) + | debugIsOn = let pp_rule rule + = ifPprDebug (ppr rule) + (doubleQuotes (ftext (ruleName rule))) in pprTrace "Rules.findBest: rule overlap (Rule 1 wins)" - (vcat [ sdocWithPprDebug $ \dbg -> if dbg - then text "Expression to match:" <+> ppr fn - <+> sep (map ppr args) - else empty + (vcat [ whenPprDebug $ + text "Expression to match:" <+> ppr fn + <+> sep (map ppr args) , text "Rule 1:" <+> pp_rule rule1 , text "Rule 2:" <+> pp_rule rule2]) $ findBest target (rule1,ans1) prs diff --git a/compiler/specialise/Specialise.hs b/compiler/specialise/Specialise.hs index 0fb7eb0472..a0844b7dfa 100644 --- a/compiler/specialise/Specialise.hs +++ b/compiler/specialise/Specialise.hs @@ -733,7 +733,7 @@ specImport dflags this_mod top_env done callers rb fn calls_for_fn = do { warnMsg (vcat [ hang (text "Could not specialise imported function" <+> quotes (ppr fn)) 2 (vcat [ text "when specialising" <+> quotes (ppr caller) | caller <- callers]) - , ifPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) + , whenPprDebug (text "calls:" <+> vcat (map (pprCallInfo fn) calls_for_fn)) , text "Probable fix: add INLINABLE pragma on" <+> quotes (ppr fn) ]) ; return ([], []) } diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs index 15181f3e5d..afbcc386ba 100644 --- a/compiler/stgSyn/StgSyn.hs +++ b/compiler/stgSyn/StgSyn.hs @@ -665,8 +665,8 @@ pprGenStgBinding (StgNonRec bndr rhs) 4 (ppr rhs <> semi) pprGenStgBinding (StgRec pairs) - = vcat $ ifPprDebug (text "{- StgRec (begin) -}") : - map (ppr_bind) pairs ++ [ifPprDebug (text "{- StgRec (end) -}")] + = vcat $ whenPprDebug (text "{- StgRec (begin) -}") : + map (ppr_bind) pairs ++ [whenPprDebug (text "{- StgRec (end) -}")] where ppr_bind (bndr, expr) = hang (hsep [pprBndr LetBind bndr, equals]) @@ -738,7 +738,7 @@ pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag a (hang (hcat [text "let { ", ppr bndr, ptext (sLit " = "), ppr cc, pp_binder_info bi, - text " [", ifPprDebug (interppSP free_vars), ptext (sLit "] \\"), + text " [", whenPprDebug (interppSP free_vars), ptext (sLit "] \\"), ppr upd_flag, text " [", interppSP args, char ']']) 8 (sep [hsep [ppr rhs, text "} in"]])) @@ -774,7 +774,7 @@ pprStgExpr (StgTick tickish expr) pprStgExpr (StgCase expr bndr alt_type alts) = sep [sep [text "case", nest 4 (hsep [pprStgExpr expr, - ifPprDebug (dcolon <+> ppr alt_type)]), + whenPprDebug (dcolon <+> ppr alt_type)]), text "of", pprBndr CaseBind bndr, char '{'], nest 2 (vcat (map pprStgAlt alts)), char '}'] @@ -803,7 +803,7 @@ pprStgRhs :: (OutputableBndr bndr, Outputable bdee, Ord bdee) pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func [])) = hsep [ ppr cc, pp_binder_info bi, - brackets (ifPprDebug (ppr free_var)), + brackets (whenPprDebug (ppr free_var)), text " \\", ppr upd_flag, ptext (sLit " [] "), ppr func ] -- general case @@ -811,7 +811,7 @@ pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body) = sdocWithDynFlags $ \dflags -> hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty, pp_binder_info bi, - ifPprDebug (brackets (interppSP free_vars)), + whenPprDebug (brackets (interppSP free_vars)), char '\\' <> ppr upd_flag, brackets (interppSP args)]) 4 (ppr body) diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index da407b8eeb..c48b6558bb 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1036,7 +1036,7 @@ checkBootTyCon is_boot tc1 tc2 -- harmless enough.) checkRoles roles1 roles2 `andThenCheck` check (eqFamFlav fam_flav1 fam_flav2) - (ifPprDebug $ + (whenPprDebug $ text "Family flavours" <+> ppr fam_flav1 <+> text "and" <+> ppr fam_flav2 <+> text "do not match") `andThenCheck` check (injInfo1 == injInfo2) (text "Injectivities do not match") @@ -2559,7 +2559,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, -- wobbling in testsuite output ppr_types :: TypeEnv -> SDoc -ppr_types type_env = sdocWithPprDebug $ \dbg -> +ppr_types type_env = getPprDebug $ \dbg -> let ids = [id | id <- typeEnvIds type_env, want_sig id] want_sig id | dbg @@ -2573,7 +2573,7 @@ ppr_types type_env = sdocWithPprDebug $ \dbg -> text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids) ppr_tycons :: [FamInst] -> TypeEnv -> SDoc -ppr_tycons fam_insts type_env = sdocWithPprDebug $ \dbg -> +ppr_tycons fam_insts type_env = getPprDebug $ \dbg -> let fi_tycons = famInstsRepTyCons fam_insts tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs index c633d975e2..b7a5d3bfde 100644 --- a/compiler/typecheck/TcRnTypes.hs +++ b/compiler/typecheck/TcRnTypes.hs @@ -3075,7 +3075,7 @@ pprSkolInfo (IPSkol ips) = text "the implicit-parameter binding" <> plural pprSkolInfo (ClsSkol cls) = text "the class declaration for" <+> quotes (ppr cls) pprSkolInfo (DerivSkol pred) = text "the deriving clause for" <+> quotes (ppr pred) pprSkolInfo InstSkol = text "the instance declaration" -pprSkolInfo (InstSC n) = text "the instance declaration" <> ifPprDebug (parens (ppr n)) +pprSkolInfo (InstSC n) = text "the instance declaration" <> whenPprDebug (parens (ppr n)) pprSkolInfo DataSkol = text "a data type declaration" pprSkolInfo FamInstSkol = text "a family instance declaration" pprSkolInfo BracketSkol = text "a Template Haskell bracket" @@ -3477,7 +3477,7 @@ pprCtO SectionOrigin = text "an operator section" pprCtO TupleOrigin = text "a tuple" pprCtO NegateOrigin = text "a use of syntactic negation" pprCtO (ScOrigin n) = text "the superclasses of an instance declaration" - <> ifPprDebug (parens (ppr n)) + <> whenPprDebug (parens (ppr n)) pprCtO DerivOrigin = text "the 'deriving' clause of a data type declaration" pprCtO StandAloneDerivOrigin = text "a 'deriving' declaration" pprCtO DefaultOrigin = text "a 'default' declaration" diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs index eaa84d6d13..c168c08a0f 100644 --- a/compiler/typecheck/TcSMonad.hs +++ b/compiler/typecheck/TcSMonad.hs @@ -362,10 +362,8 @@ instance Outputable WorkList where , ppUnless (null ders) $ text "Derived =" <+> vcat (map ppr ders) , ppUnless (isEmptyBag implics) $ - sdocWithPprDebug $ \dbg -> - if dbg -- Typically we only want the work list for this level - then text "Implics =" <+> vcat (map ppr (bagToList implics)) - else text "(Implics omitted)" + ifPprDebug (text "Implics =" <+> vcat (map ppr (bagToList implics))) + (text "(Implics omitted)") ]) diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index f0afdb6499..01baa6f225 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -1743,6 +1743,9 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl -- See Note [Wrong visibility for GADTs] univ_bndrs = mkTyVarBinders Specified univ_tvs ex_bndrs = mkTyVarBinders Specified ex_tvs + ctxt' = substTys arg_subst ctxt + arg_tys' = substTys arg_subst arg_tys + res_ty' = substTy arg_subst res_ty ; fam_envs <- tcGetFamInstEnvs @@ -1757,10 +1760,7 @@ tcConDecl rep_tycon tmpl_bndrs res_tmpl rep_nm stricts Nothing field_lbls univ_bndrs ex_bndrs eq_preds - (substTys arg_subst ctxt) - (substTys arg_subst arg_tys) - (substTy arg_subst res_ty) - rep_tycon + ctxt' arg_tys' res_ty' rep_tycon -- NB: we put data_tc, the type constructor gotten from the -- constructor type signature into the data constructor; -- that way checkValidDataCon can complain if it's wrong. diff --git a/compiler/types/FamInstEnv.hs b/compiler/types/FamInstEnv.hs index dbf090feda..451f427d08 100644 --- a/compiler/types/FamInstEnv.hs +++ b/compiler/types/FamInstEnv.hs @@ -259,7 +259,7 @@ instance Outputable FamInst where -- See pprTyThing.pprFamInst for printing for the user pprFamInst :: FamInst -> SDoc pprFamInst famInst - = hang (pprFamInstHdr famInst) 2 (ifPprDebug debug_stuff) + = hang (pprFamInstHdr famInst) 2 (whenPprDebug debug_stuff) where ax = fi_axiom famInst debug_stuff = vcat [ text "Coercion axiom:" <+> ppr ax diff --git a/compiler/types/InstEnv.hs b/compiler/types/InstEnv.hs index 8198a5360f..80b9b901c2 100644 --- a/compiler/types/InstEnv.hs +++ b/compiler/types/InstEnv.hs @@ -213,7 +213,7 @@ pprInstance :: ClsInst -> SDoc pprInstance ispec = hang (pprInstanceHdr ispec) 2 (vcat [ text "--" <+> pprDefinedAt (getName ispec) - , ifPprDebug (ppr (is_dfun ispec)) ]) + , whenPprDebug (ppr (is_dfun ispec)) ]) -- * pprInstanceHdr is used in VStudio to populate the ClassView tree pprInstanceHdr :: ClsInst -> SDoc diff --git a/compiler/types/TyCoRep.hs b/compiler/types/TyCoRep.hs index 0fbcc2c0ba..80681e7678 100644 --- a/compiler/types/TyCoRep.hs +++ b/compiler/types/TyCoRep.hs @@ -66,6 +66,8 @@ module TyCoRep ( pprCo, pprParendCo, + debugPprType, + -- * Free variables tyCoVarsOfType, tyCoVarsOfTypeDSet, tyCoVarsOfTypes, tyCoVarsOfTypesDSet, tyCoFVsBndr, tyCoFVsOfType, tyCoVarsOfTypeList, @@ -2505,7 +2507,6 @@ instance Outputable TyLit where ppr = pprTyLit ------------------ - pprSigmaType :: Type -> SDoc pprSigmaType = pprIfaceSigmaType ShowForAllWhen . tidyToIfaceType @@ -2546,6 +2547,64 @@ instance Outputable TyBinder where instance Outputable Coercion where -- defined here to avoid orphans ppr = pprCo +debugPprType :: Type -> SDoc +-- ^ debugPprType is a simple pretty printer that prints a type +-- without going through IfaceType. It does not format as prettily +-- as the normal route, but it's much more direct, and that can +-- be useful for debugging. E.g. with -dppr-debug it prints the +-- kind on type-variable /occurrences/ which the normal route +-- fundamentally cannot do. +debugPprType ty = debug_ppr_ty TopPrec ty + +debug_ppr_ty :: TyPrec -> Type -> SDoc +debug_ppr_ty _ (LitTy l) + = ppr l + +debug_ppr_ty _ (TyVarTy tv) + = ifPprDebug (parens (ppr tv <+> dcolon + <+> (debugPprType (tyVarKind tv)))) + (ppr tv) + +debug_ppr_ty prec (FunTy arg res) + = maybeParen prec FunPrec $ + sep [debug_ppr_ty FunPrec arg, arrow <+> debug_ppr_ty prec res] + +debug_ppr_ty prec (TyConApp tc tys) + | null tys = ppr tc + | otherwise = maybeParen prec TyConPrec $ + hang (ppr tc) 2 (sep (map (debug_ppr_ty TyConPrec) tys)) + +debug_ppr_ty prec (AppTy t1 t2) + = hang (debug_ppr_ty prec t1) + 2 (debug_ppr_ty TyConPrec t2) + +debug_ppr_ty prec (CastTy ty co) + = maybeParen prec TopPrec $ + hang (debug_ppr_ty TopPrec ty) + 2 (text "|>" <+> ppr co) + +debug_ppr_ty _ (CoercionTy co) + = parens (text "CO" <+> ppr co) + +debug_ppr_ty prec ty@(ForAllTy {}) + | (tvs, body) <- split ty + = maybeParen prec FunPrec $ + hang (text "forall" <+> fsep (map pp_bndr tvs) <> dot) + 2 (ppr body) + where + split ty | ForAllTy tv ty' <- ty + , (tvs, body) <- split ty' + = (tv:tvs, body) + | otherwise + = ([], ty) + + pp_bndr, pp_with_kind :: TyVarBinder -> SDoc + pp_bndr tv = ifPprDebug (ppr tv) (pp_with_kind tv) + + pp_with_kind tv + = parens (ppr tv <+> dcolon + <+> ppr (tyVarKind (binderVar tv))) + {- Note [When to print foralls] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs index bc46f2f472..5cd7656b4f 100644 --- a/compiler/utils/Outputable.hs +++ b/compiler/utils/Outputable.hs @@ -15,7 +15,7 @@ module Outputable ( -- * Pretty printing combinators SDoc, runSDoc, initSDocContext, - docToSDoc, sdocWithPprDebug, + docToSDoc, interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, quotedListWithNor, pprWithBars, @@ -72,10 +72,12 @@ module Outputable ( getPprStyle, withPprStyle, withPprStyleDoc, setStyleColoured, pprDeeper, pprDeeperList, pprSetDepth, codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, - ifPprDebug, qualName, qualModule, qualPackage, + qualName, qualModule, qualPackage, mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, mkUserStyle, cmdlineParserStyle, Depth(..), + ifPprDebug, whenPprDebug, getPprDebug, + -- * Error handling and debugging utilities pprPanic, pprSorry, assertPprPanic, pprPgmError, pprTrace, pprTraceDebug, pprTraceIt, warnPprTrace, pprSTrace, @@ -247,8 +249,8 @@ defaultUserStyle dflags = mkUserStyle dflags neverQualify AllTheWay defaultDumpStyle :: DynFlags -> PprStyle -- Print without qualifiers to reduce verbosity, unless -dppr-debug defaultDumpStyle dflags - | hasPprDebug dflags = PprDebug - | otherwise = PprDump neverQualify + | hasPprDebug dflags = PprDebug + | otherwise = PprDump neverQualify mkDumpStyle :: DynFlags -> PrintUnqualified -> PprStyle mkDumpStyle dflags print_unqual @@ -339,9 +341,6 @@ withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty) -sdocWithPprDebug :: (Bool -> SDoc) -> SDoc -sdocWithPprDebug f = sdocWithDynFlags $ \dflags -> f (hasPprDebug dflags) - pprDeeper :: SDoc -> SDoc pprDeeper d = SDoc $ \ctx -> case ctx of SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..." @@ -422,11 +421,16 @@ userStyle :: PprStyle -> Bool userStyle (PprUser {}) = True userStyle _other = False -ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style -ifPprDebug d = SDoc $ \ctx -> - case ctx of - SDC{sdocStyle=PprDebug} -> runSDoc d ctx - _ -> Pretty.empty +getPprDebug :: (Bool -> SDoc) -> SDoc +getPprDebug d = getPprStyle $ \ sty -> d (debugStyle sty) + +ifPprDebug :: SDoc -> SDoc -> SDoc +-- ^ Says what to do with and without -dppr-debug +ifPprDebug yes no = getPprDebug $ \ dbg -> if dbg then yes else no + +whenPprDebug :: SDoc -> SDoc -- Empty for non-debug style +-- ^ Says what to do with -dppr-debug; without, return empty +whenPprDebug d = ifPprDebug d empty -- | The analog of 'Pretty.printDoc_' for 'SDoc', which tries to make sure the -- terminal doesn't get screwed up by the ANSI color codes if an exception |