diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2020-03-17 18:44:51 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2020-05-01 10:37:39 -0400 |
commit | de9fc995c2170bc34600ee3fc80393c67cfecad1 (patch) | |
tree | 71a179e2b899cf9253ada7bddea40ab3c1e1c3e6 | |
parent | b3df9e780fb2f5658412c644849cd0f1e6f50331 (diff) | |
download | haskell-de9fc995c2170bc34600ee3fc80393c67cfecad1.tar.gz |
Fully remove PprDebug
PprDebug was a pain to deal with consistently as it is implied by
`-dppr-debug` but it isn't really a PprStyle. We remove it completely
and query the appropriate SDoc flag instead (`sdocPprDebug`) via
helpers (`getPprDebug` and its friends).
-rw-r--r-- | compiler/GHC/Core/Ppr.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Core/TyCo/Ppr.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Core/TyCon.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Hs/Binds.hs | 17 | ||||
-rw-r--r-- | compiler/GHC/Hs/Expr.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Hs/Pat.hs | 13 | ||||
-rw-r--r-- | compiler/GHC/Iface/Type.hs | 16 | ||||
-rw-r--r-- | compiler/GHC/ThToHs.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Types/Name.hs | 29 | ||||
-rw-r--r-- | compiler/GHC/Types/Name/Occurrence.hs | 5 | ||||
-rw-r--r-- | compiler/GHC/Types/Var.hs | 34 | ||||
-rw-r--r-- | compiler/GHC/Unit/Types.hs | 8 | ||||
-rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 37 |
13 files changed, 102 insertions, 94 deletions
diff --git a/compiler/GHC/Core/Ppr.hs b/compiler/GHC/Core/Ppr.hs index e9c746d7a6..c0b2749359 100644 --- a/compiler/GHC/Core/Ppr.hs +++ b/compiler/GHC/Core/Ppr.hs @@ -375,8 +375,8 @@ pprCoreBinder LetBind binder -- Lambda bound type variables are preceded by "@" pprCoreBinder bind_site bndr - = getPprStyle $ \ sty -> - pprTypedLamBinder bind_site (debugStyle sty) bndr + = getPprDebug $ \debug -> + pprTypedLamBinder bind_site debug bndr pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs index 973641bf5c..6678a00559 100644 --- a/compiler/GHC/Core/TyCo/Ppr.hs +++ b/compiler/GHC/Core/TyCo/Ppr.hs @@ -93,7 +93,8 @@ pprPrecType = pprPrecTypeX emptyTidyEnv pprPrecTypeX :: TidyEnv -> PprPrec -> Type -> SDoc pprPrecTypeX env prec ty = getPprStyle $ \sty -> - if debugStyle sty -- Use debugPprType when in + getPprDebug $ \debug -> + if debug -- Use debugPprType when in then debug_ppr_ty prec ty -- when in debug-style else pprPrecIfaceType prec (tidyToIfaceTypeStyX env ty sty) -- NB: debug-style is used for -dppr-debug diff --git a/compiler/GHC/Core/TyCon.hs b/compiler/GHC/Core/TyCon.hs index 863c3b2f46..0f850f2278 100644 --- a/compiler/GHC/Core/TyCon.hs +++ b/compiler/GHC/Core/TyCon.hs @@ -2576,9 +2576,11 @@ instance Outputable TyCon where -- corresponding TyCon, so we add the quote to distinguish it here ppr tc = pprPromotionQuote tc <> ppr (tyConName tc) <> pp_tc where - pp_tc = getPprStyle $ \sty -> if ((debugStyle sty || dumpStyle sty) && isTcTyCon tc) - then text "[tc]" - else empty + pp_tc = getPprStyle $ \sty -> + getPprDebug $ \debug -> + if ((debug || dumpStyle sty) && isTcTyCon tc) + then text "[tc]" + else empty -- | Paints a picture of what a 'TyCon' represents, in broad strokes. -- This is used towards more informative error messages. diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 0252656203..ccc5a8d422 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -630,11 +630,10 @@ instance (OutputableBndrId pl, OutputableBndrId pr) = pprDeclList (pprLHsBindsForUser binds sigs) ppr (XValBindsLR (NValBinds sccs sigs)) - = getPprStyle $ \ sty -> - if debugStyle sty then -- Print with sccs showing - vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) - else - pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) + = getPprDebug $ \case + -- Print with sccs showing + True -> vcat (map ppr sigs) $$ vcat (map ppr_scc sccs) + False -> pprDeclList (pprLHsBindsForUser (unionManyBags (map snd sccs)) sigs) where ppr_scc (rec_flag, binds) = pp_rec rec_flag <+> pprLHsBinds binds pp_rec Recursive = text "rec" @@ -784,9 +783,11 @@ pprTicks :: SDoc -> SDoc -> SDoc -- Also print ticks in dumpStyle, so that -ddump-hpc actually does -- something useful. pprTicks pp_no_debug pp_when_debug - = getPprStyle (\ sty -> if debugStyle sty || dumpStyle sty - then pp_when_debug - else pp_no_debug) + = getPprStyle $ \sty -> + getPprDebug $ \debug -> + if debug || dumpStyle sty + then pp_when_debug + else pp_no_debug {- ************************************************************************ diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs index 97eab7d3aa..2ef0d62db4 100644 --- a/compiler/GHC/Hs/Expr.hs +++ b/compiler/GHC/Hs/Expr.hs @@ -17,6 +17,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -187,8 +188,8 @@ instance Outputable SyntaxExprTc where , syn_arg_wraps = arg_wraps , syn_res_wrap = res_wrap }) = sdocOption sdocPrintExplicitCoercions $ \print_co -> - getPprStyle $ \s -> - if debugStyle s || print_co + getPprDebug $ \debug -> + if debug || print_co then ppr expr <> braces (pprWithCommas ppr arg_wraps) <> braces (ppr res_wrap) else ppr expr @@ -1141,9 +1142,9 @@ can see the structure of the parse tree. pprDebugParendExpr :: (OutputableBndrId p) => PprPrec -> LHsExpr (GhcPass p) -> SDoc pprDebugParendExpr p expr - = getPprStyle (\sty -> - if debugStyle sty then pprParendLExpr p expr - else pprLExpr expr) + = getPprDebug $ \case + True -> pprParendLExpr p expr + False -> pprLExpr expr pprParendLExpr :: (OutputableBndrId p) => PprPrec -> LHsExpr (GhcPass p) -> SDoc diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs index 4f73aa3e98..50d3cf4aef 100644 --- a/compiler/GHC/Hs/Pat.hs +++ b/compiler/GHC/Hs/Pat.hs @@ -514,14 +514,13 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hsRecFieldLbl instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where ppr = pprPat +-- | Print with type info if -dppr-debug is on pprPatBndr :: OutputableBndr name => name -> SDoc -pprPatBndr var -- Print with type info if -dppr-debug is on - = getPprStyle $ \ sty -> - if debugStyle sty then - parens (pprBndr LambdaBind var) -- Could pass the site to pprPat - -- but is it worth it? - else - pprPrefixOcc var +pprPatBndr var + = getPprDebug $ \case + True -> parens (pprBndr LambdaBind var) -- Could pass the site to pprPat + -- but is it worth it? + False -> pprPrefixOcc var pprParendLPat :: (OutputableBndrId p) => PprPrec -> LPat (GhcPass p) -> SDoc diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs index 5c2172f96f..40ba0d54a1 100644 --- a/compiler/GHC/Iface/Type.hs +++ b/compiler/GHC/Iface/Type.hs @@ -692,7 +692,8 @@ if_print_coercions :: SDoc -- ^ if printing coercions if_print_coercions yes no = sdocOption sdocPrintExplicitCoercions $ \print_co -> getPprStyle $ \style -> - if print_co || dumpStyle style || debugStyle style + getPprDebug $ \debug -> + if print_co || dumpStyle style || debug then yes else no @@ -1286,12 +1287,12 @@ pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc pprTyTcApp ctxt_prec tc tys = sdocOption sdocPrintExplicitKinds $ \print_kinds -> - getPprStyle $ \style -> - pprTyTcApp' ctxt_prec tc tys (PrintExplicitKinds print_kinds) style + getPprDebug $ \debug -> + pprTyTcApp' ctxt_prec tc tys (PrintExplicitKinds print_kinds) debug pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs - -> PrintExplicitKinds -> PprStyle -> SDoc -pprTyTcApp' ctxt_prec tc tys printExplicitKinds style + -> PrintExplicitKinds -> Bool -> SDoc +pprTyTcApp' ctxt_prec tc tys printExplicitKinds debug | ifaceTyConName tc `hasKey` ipClassKey , IA_Arg (IfaceLitTy (IfaceStrTyLit n)) Required (IA_Arg ty Required IA_Nil) <- tys @@ -1299,7 +1300,7 @@ pprTyTcApp' ctxt_prec tc tys printExplicitKinds style $ char '?' <> ftext n <> text "::" <> ppr_ty topPrec ty | IfaceTupleTyCon arity sort <- ifaceTyConSort info - , not (debugStyle style) + , not debug , arity == ifaceVisAppArgsLength tys = pprTuple ctxt_prec sort (ifaceTyConIsPromoted info) tys @@ -1382,8 +1383,9 @@ ppr_equality ctxt_prec tc args sdocOption sdocPrintExplicitKinds $ \print_kinds -> sdocOption sdocPrintEqualityRelations $ \print_eqs -> getPprStyle $ \style -> + getPprDebug $ \debug -> print_equality' args print_kinds - (print_eqs || dumpStyle style || debugStyle style) + (print_eqs || dumpStyle style || debug) print_equality' (ki1, ki2, ty1, ty2) print_kinds print_eqs | -- If -fprint-equality-relations is on, just print the original TyCon diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 6c7e121bd6..b0d797885b 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -11,6 +11,7 @@ This module converts Template Haskell syntax into Hs syntax {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -134,15 +135,15 @@ wrapMsg :: (Show a, TH.Ppr a) => String -> a -> CvtM b -> CvtM b -- E.g wrapMsg "declaration" dec thing wrapMsg what item (CvtM m) = CvtM $ \origin loc -> case m origin loc of - Left err -> Left (err $$ getPprStyle msg) + Left err -> Left (err $$ msg) Right v -> Right v where -- Show the item in pretty syntax normally, -- but with all its constructors if you say -dppr-debug - msg sty = hang (text "When splicing a TH" <+> text what <> colon) - 2 (if debugStyle sty - then text (show item) - else text (pprint item)) + msg = hang (text "When splicing a TH" <+> text what <> colon) + 2 (getPprDebug $ \case + True -> text (show item) + False -> text (pprint item)) wrapL :: CvtM a -> CvtM (Located a) wrapL (CvtM m) = CvtM $ \origin loc -> case m origin loc of diff --git a/compiler/GHC/Types/Name.hs b/compiler/GHC/Types/Name.hs index fe316542ae..e587b08d0a 100644 --- a/compiler/GHC/Types/Name.hs +++ b/compiler/GHC/Types/Name.hs @@ -531,24 +531,25 @@ instance OutputableBndr Name where pprName :: Name -> SDoc pprName (Name {n_sort = sort, n_uniq = uniq, n_occ = occ}) - = getPprStyle $ \ sty -> + = getPprStyle $ \sty -> + getPprDebug $ \debug -> case sort of - WiredIn mod _ builtin -> pprExternal sty uniq mod occ True builtin - External mod -> pprExternal sty uniq mod occ False UserSyntax - System -> pprSystem sty uniq occ - Internal -> pprInternal sty uniq occ + WiredIn mod _ builtin -> pprExternal debug sty uniq mod occ True builtin + External mod -> pprExternal debug sty uniq mod occ False UserSyntax + System -> pprSystem debug sty uniq occ + Internal -> pprInternal debug sty uniq occ -- | Print the string of Name unqualifiedly directly. pprNameUnqualified :: Name -> SDoc pprNameUnqualified Name { n_occ = occ } = ppr_occ_name occ -pprExternal :: PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc -pprExternal sty uniq mod occ is_wired is_builtin +pprExternal :: Bool -> PprStyle -> Unique -> Module -> OccName -> Bool -> BuiltInSyntax -> SDoc +pprExternal debug sty uniq mod occ is_wired is_builtin | codeStyle sty = ppr mod <> char '_' <> ppr_z_occ_name occ -- In code style, always qualify -- ToDo: maybe we could print all wired-in things unqualified -- in code style, to reduce symbol table bloat? - | debugStyle sty = pp_mod <> ppr_occ_name occ + | debug = pp_mod <> ppr_occ_name occ <> braces (hsep [if is_wired then text "(w)" else empty, pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) @@ -563,10 +564,10 @@ pprExternal sty uniq mod occ is_wired is_builtin pp_mod = ppUnlessOption sdocSuppressModulePrefixes (ppr mod <> dot) -pprInternal :: PprStyle -> Unique -> OccName -> SDoc -pprInternal sty uniq occ +pprInternal :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprInternal debug sty uniq occ | codeStyle sty = pprUniqueAlways uniq - | debugStyle sty = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), + | debug = ppr_occ_name occ <> braces (hsep [pprNameSpaceBrief (occNameSpace occ), pprUnique uniq]) | dumpStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq -- For debug dumps, we're not necessarily dumping @@ -574,10 +575,10 @@ pprInternal sty uniq occ | otherwise = ppr_occ_name occ -- User style -- Like Internal, except that we only omit the unique in Iface style -pprSystem :: PprStyle -> Unique -> OccName -> SDoc -pprSystem sty uniq occ +pprSystem :: Bool -> PprStyle -> Unique -> OccName -> SDoc +pprSystem debug sty uniq occ | codeStyle sty = pprUniqueAlways uniq - | debugStyle sty = ppr_occ_name occ <> ppr_underscore_unique uniq + | debug = ppr_occ_name occ <> ppr_underscore_unique uniq <> braces (pprNameSpaceBrief (occNameSpace occ)) | otherwise = ppr_occ_name occ <> ppr_underscore_unique uniq -- If the tidy phase hasn't run, the OccName diff --git a/compiler/GHC/Types/Name/Occurrence.hs b/compiler/GHC/Types/Name/Occurrence.hs index 4c5ac689f2..d7f7cc8c9d 100644 --- a/compiler/GHC/Types/Name/Occurrence.hs +++ b/compiler/GHC/Types/Name/Occurrence.hs @@ -273,11 +273,8 @@ pprOccName (OccName sp occ) = getPprStyle $ \ sty -> if codeStyle sty then ztext (zEncodeFS occ) - else pp_occ <> pp_debug sty + else pp_occ <> whenPprDebug (braces (pprNameSpaceBrief sp)) where - pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp) - | otherwise = empty - pp_occ = sdocOption sdocSuppressUniques $ \case True -> text (strip_th_unique (unpackFS occ)) False -> ftext occ diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs index 1479856fb4..d58065305e 100644 --- a/compiler/GHC/Types/Var.hs +++ b/compiler/GHC/Types/Var.hs @@ -300,21 +300,29 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds instance Outputable Var where ppr var = sdocOption sdocSuppressVarKinds $ \supp_var_kinds -> - getPprStyle $ \ppr_style -> - if | debugStyle ppr_style && (not supp_var_kinds) - -> parens (ppr (varName var) <+> ppr_debug var ppr_style <+> + getPprDebug $ \debug -> + getPprStyle $ \sty -> + let + ppr_var = case var of + (TyVar {}) + | debug + -> brackets (text "tv") + + (TcTyVar {tc_tv_details = d}) + | dumpStyle sty || debug + -> brackets (pprTcTyVarDetails d) + + (Id { idScope = s, id_details = d }) + | debug + -> brackets (ppr_id_scope s <> pprIdDetails d) + + _ -> empty + in if + | debug && (not supp_var_kinds) + -> parens (ppr (varName var) <+> ppr_var <+> dcolon <+> pprKind (tyVarKind var)) | otherwise - -> ppr (varName var) <> ppr_debug var ppr_style - -ppr_debug :: Var -> PprStyle -> SDoc -ppr_debug (TyVar {}) sty - | debugStyle sty = brackets (text "tv") -ppr_debug (TcTyVar {tc_tv_details = d}) sty - | dumpStyle sty || debugStyle sty = brackets (pprTcTyVarDetails d) -ppr_debug (Id { idScope = s, id_details = d }) sty - | debugStyle sty = brackets (ppr_id_scope s <> pprIdDetails d) -ppr_debug _ _ = empty + -> ppr (varName var) <> ppr_var ppr_id_scope :: IdScope -> SDoc ppr_id_scope GlobalId = text "gid" diff --git a/compiler/GHC/Unit/Types.hs b/compiler/GHC/Unit/Types.hs index a42f0c0c78..7282b385b6 100644 --- a/compiler/GHC/Unit/Types.hs +++ b/compiler/GHC/Unit/Types.hs @@ -506,10 +506,10 @@ instance Uniquable UnitId where instance Outputable UnitId where ppr uid@(UnitId fs) = - getPprStyle $ \sty -> + getPprDebug $ \debug -> sdocWithDynFlags $ \dflags -> case displayUnitId (pkgState dflags) uid of - Just str | not (debugStyle sty) -> text str + Just str | not debug -> text str _ -> ftext fs -- | A 'DefUnitId' is an 'UnitId' with the invariant that @@ -562,8 +562,8 @@ instance Uniquable unit => Uniquable (Indefinite unit) where instance Outputable unit => Outputable (Indefinite unit) where ppr (Indefinite uid Nothing) = ppr uid ppr (Indefinite uid (Just pprinfo)) = - getPprStyle $ \sty -> - if debugStyle sty + getPprDebug $ \debug -> + if debug then ppr uid else ppr pprinfo diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs index b103d3494b..ba843cef30 100644 --- a/compiler/GHC/Utils/Outputable.hs +++ b/compiler/GHC/Utils/Outputable.hs @@ -76,7 +76,7 @@ module GHC.Utils.Outputable ( SDocContext (..), sdocWithContext, getPprStyle, withPprStyle, setStyleColoured, pprDeeper, pprDeeperList, pprSetDepth, - codeStyle, userStyle, debugStyle, dumpStyle, asmStyle, + codeStyle, userStyle, dumpStyle, asmStyle, qualName, qualModule, qualPackage, mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle, mkUserStyle, cmdlineParserStyle, Depth(..), @@ -155,12 +155,10 @@ data PprStyle -- printed without uniques. | PprDump PrintUnqualified - -- For -ddump-foo; less verbose than PprDebug, but more than PprUser + -- For -ddump-foo; less verbose than in ppr-debug mode, but more than PprUser -- Does not assume tidied code: non-external names -- are printed with uniques. - | PprDebug -- Full debugging output - | PprCode CodeStyle -- Print code; either C or assembler @@ -262,11 +260,10 @@ defaultDumpStyle = PprDump neverQualify mkDumpStyle :: PrintUnqualified -> PprStyle mkDumpStyle print_unqual = PprDump print_unqual -defaultErrStyle :: DynFlags -> PprStyle --- Default style for error messages, when we don't know PrintUnqualified +-- | Default style for error messages, when we don't know PrintUnqualified -- It's a bit of a hack because it doesn't take into account what's in scope -- Only used for desugarer warnings, and typechecker errors in interface sigs --- NB that -dppr-debug will still get into PprDebug style +defaultErrStyle :: DynFlags -> PprStyle defaultErrStyle dflags = mkErrStyle dflags neverQualify -- | Style for printing error messages @@ -281,9 +278,7 @@ mkUserStyle :: PrintUnqualified -> Depth -> PprStyle mkUserStyle unqual depth = PprUser unqual depth Uncoloured withUserStyle :: PrintUnqualified -> Depth -> SDoc -> SDoc -withUserStyle unqual depth doc = sdocOption sdocPprDebug $ \case - True -> withPprStyle PprDebug doc - False -> withPprStyle (PprUser unqual depth Uncoloured) doc +withUserStyle unqual depth doc = withPprStyle (PprUser unqual depth Uncoloured) doc withErrStyle :: PrintUnqualified -> SDoc -> SDoc withErrStyle unqual doc = @@ -303,7 +298,6 @@ instance Outputable PprStyle where ppr (PprUser {}) = text "user-style" ppr (PprCode {}) = text "code-style" ppr (PprDump {}) = text "dump-style" - ppr (PprDebug {}) = text "debug-style" {- Orthogonal to the above printing styles are (possibly) some @@ -457,23 +451,20 @@ dumpStyle :: PprStyle -> Bool dumpStyle (PprDump {}) = True dumpStyle _other = False -debugStyle :: PprStyle -> Bool -debugStyle PprDebug = True -debugStyle _other = False - userStyle :: PprStyle -> Bool userStyle (PprUser {}) = True userStyle _other = False +-- | Indicate if -dppr-debug mode is enabled getPprDebug :: (Bool -> SDoc) -> SDoc -getPprDebug d = getPprStyle $ \ sty -> d (debugStyle sty) +getPprDebug d = sdocWithContext $ \ctx -> d (sdocPprDebug ctx) +-- | Says what to do with and without -dppr-debug ifPprDebug :: SDoc -> SDoc -> SDoc --- ^ Says what to do with and without -dppr-debug -ifPprDebug yes no = getPprDebug $ \ dbg -> if dbg then yes else no +ifPprDebug yes no = getPprDebug $ \dbg -> if dbg then yes else no +-- | Says what to do with -dppr-debug; without, return empty 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 @@ -550,7 +541,11 @@ showSDocDump :: DynFlags -> SDoc -> String showSDocDump dflags d = renderWithStyle (initSDocContext dflags defaultDumpStyle) d showSDocDebug :: DynFlags -> SDoc -> String -showSDocDebug dflags d = renderWithStyle (initSDocContext dflags PprDebug) d +showSDocDebug dflags d = renderWithStyle ctx d + where + ctx = (initSDocContext dflags defaultDumpStyle) + { sdocPprDebug = True + } renderWithStyle :: SDocContext -> SDoc -> String renderWithStyle ctx sdoc @@ -580,7 +575,7 @@ irrelevantNCols :: Int irrelevantNCols = 1 isEmpty :: SDocContext -> SDoc -> Bool -isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocStyle = PprDebug}) +isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocPprDebug = True}) docToSDoc :: Doc -> SDoc docToSDoc d = SDoc (\_ -> d) |