Commit 805b29bb authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

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
parent fca19628
......@@ -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)
{-
************************************************************************
......
......@@ -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)]
......
......@@ -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
{-
......
......@@ -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)
......
......@@ -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 '}'
......
......@@ -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 ()
......
......@@ -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
......
......@@ -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)
......
......@@ -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
......
......@@ -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))
......
......@@ -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
......
......@@ -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
......
......@@ -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 #-}" <>
......
......@@ -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 ...)"
......
......@@ -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
}}}
......
......@@ -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 '-' <>
......
......@@ -516,7 +516,7 @@ pprDataItem' dflags lit
asmComment :: SDoc -> SDoc
asmComment c = ifPprDebug $ text "# " <> c
asmComment c = whenPprDebug $ text "# " <> c
pprInstr :: Instr -> SDoc
......
......@@ -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 "-}"
......
......@@ -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
......
......@@ -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
......
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