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

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
......
......@@ -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]
......
......@@ -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
......
......@@ -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 ([], []) }
......
......@@ -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)
......
......@@ -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]
......
......@@ -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"
......
......@@ -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)")
])
......
......@@ -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.
......
......@@ -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
......
......@@ -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
......
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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
......
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