Commit 6880d6aa authored by Sylvain Henry's avatar Sylvain Henry Committed by Marge Bot

Disentangle DynFlags and SDoc

Remove several uses of `sdocWithDynFlags`. The remaining ones are mostly
CodeGen related (e.g. depend on target platform constants) and will be
fixed separately.

Metric Decrease:
   T12425
   T9961
   WWRec
   T1969
   T14683
parent 74ad75e8
Pipeline #16041 failed with stages
{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
----------------------------------------------------------------------------
......@@ -45,7 +46,6 @@ import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import DynFlags
import FastString
import Outputable
import GHC.Cmm.Ppr.Decl
......@@ -181,22 +181,22 @@ pprNode :: CmmNode e x -> SDoc
pprNode node = pp_node <+> pp_debug
where
pp_node :: SDoc
pp_node = sdocWithDynFlags $ \dflags -> case node of
pp_node = case node of
-- label:
CmmEntry id tscope -> lbl <> colon <+>
(sdocWithDynFlags $ \dflags ->
ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))
where
lbl = if gopt Opt_SuppressUniques dflags
then text "_lbl_"
else ppr id
CmmEntry id tscope ->
(sdocOption sdocSuppressUniques $ \case
True -> text "_lbl_"
False -> ppr id
)
<> colon
<+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope)
-- // text
CmmComment s -> text "//" <+> ftext s
-- //tick bla<...>
CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $
text "//tick" <+> ppr t
CmmTick t -> ppUnlessOption sdocSuppressTicks
(text "//tick" <+> ppr t)
-- unwind reg = expr;
CmmUnwind regs ->
......
......@@ -31,8 +31,9 @@
--
-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
--
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module GHC.Cmm.Ppr.Expr
( pprExpr, pprLit
)
......@@ -43,7 +44,6 @@ import GhcPrelude
import GHC.Cmm.Expr
import Outputable
import DynFlags
import Data.Maybe
import Numeric ( fromRat )
......@@ -227,18 +227,17 @@ pprReg r
-- We only print the type of the local reg if it isn't wordRep
--
pprLocalReg :: LocalReg -> SDoc
pprLocalReg (LocalReg uniq rep) = sdocWithDynFlags $ \dflags ->
pprLocalReg (LocalReg uniq rep) =
-- = ppr rep <> char '_' <> ppr uniq
-- Temp Jan08
char '_' <> pprUnique dflags uniq <>
char '_' <> pprUnique uniq <>
(if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh
then dcolon <> ptr <> ppr rep
else dcolon <> ptr <> ppr rep)
where
pprUnique dflags unique =
if gopt Opt_SuppressUniques dflags
then text "_locVar_"
else ppr unique
pprUnique unique = sdocOption sdocSuppressUniques $ \case
True -> text "_locVar_"
False -> ppr unique
ptr = empty
--if isGcPtrType rep
-- then doubleQuotes (text "ptr")
......
......@@ -506,7 +506,9 @@ strCLabel_llvm :: CLabel -> LlvmM LMString
strCLabel_llvm lbl = do
dflags <- getDynFlags
let sdoc = pprCLabel dflags lbl
str = Outp.renderWithStyle dflags sdoc (Outp.mkCodeStyle Outp.CStyle)
str = Outp.renderWithStyle
(initSDocContext dflags (Outp.mkCodeStyle Outp.CStyle))
sdoc
return (fsLit str)
strDisplayName_llvm :: CLabel -> LlvmM LMString
......@@ -515,7 +517,7 @@ strDisplayName_llvm lbl = do
let sdoc = pprCLabel dflags lbl
depth = Outp.PartWay 1
style = Outp.mkUserStyle dflags Outp.reallyAlwaysQualify depth
str = Outp.renderWithStyle dflags sdoc style
str = Outp.renderWithStyle (initSDocContext dflags style) sdoc
return (fsLit (dropInfoSuffix str))
dropInfoSuffix :: String -> String
......@@ -532,7 +534,7 @@ strProcedureName_llvm lbl = do
let sdoc = pprCLabel dflags lbl
depth = Outp.PartWay 1
style = Outp.mkUserStyle dflags Outp.neverQualify depth
str = Outp.renderWithStyle dflags sdoc style
str = Outp.renderWithStyle (initSDocContext dflags style) sdoc
return (fsLit str)
-- ----------------------------------------------------------------------------
......
......@@ -1505,7 +1505,7 @@ genMachOp_slow opt op [x, y] = case op of
-- Error. Continue anyway so we can debug the generated ll file.
dflags <- getDynFlags
let style = mkCodeStyle CStyle
toString doc = renderWithStyle dflags doc style
toString doc = renderWithStyle (initSDocContext dflags style) doc
cmmToStr = (lines . toString . PprCmm.pprExpr)
statement $ Comment $ map fsLit $ cmmToStr x
statement $ Comment $ map fsLit $ cmmToStr y
......
......@@ -19,6 +19,7 @@ Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@.
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Hs.Binds where
......@@ -42,7 +43,6 @@ import Var
import Bag
import FastString
import BooleanFormula (LBooleanFormula)
import DynFlags
import Data.Data hiding ( Fixity )
import Data.List hiding ( foldr )
......@@ -739,20 +739,19 @@ ppr_monobind (PatSynBind _ psb) = ppr psb
ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
, abs_exports = exports, abs_binds = val_binds
, abs_ev_binds = ev_binds })
= sdocWithDynFlags $ \ dflags ->
if gopt Opt_PrintTypecheckerElaboration dflags then
-- Show extra information (bug number: #10662)
hang (text "AbsBinds" <+> brackets (interpp'SP tyvars)
<+> brackets (interpp'SP dictvars))
2 $ braces $ vcat
[ text "Exports:" <+>
brackets (sep (punctuate comma (map ppr exports)))
, text "Exported types:" <+>
vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
, text "Binds:" <+> pprLHsBinds val_binds
, pprIfTc @idR (text "Evidence:" <+> ppr ev_binds) ]
else
pprLHsBinds val_binds
= sdocOption sdocPrintTypecheckerElaboration $ \case
False -> pprLHsBinds val_binds
True -> -- Show extra information (bug number: #10662)
hang (text "AbsBinds" <+> brackets (interpp'SP tyvars)
<+> brackets (interpp'SP dictvars))
2 $ braces $ vcat
[ text "Exports:" <+>
brackets (sep (punctuate comma (map ppr exports)))
, text "Exported types:" <+>
vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
, text "Binds:" <+> pprLHsBinds val_binds
, pprIfTc @idR (text "Evidence:" <+> ppr ev_binds)
]
ppr_monobind (XHsBindsLR x) = ppr x
instance OutputableBndrId p => Outputable (ABExport (GhcPass p)) where
......
......@@ -38,7 +38,6 @@ import GHC.Hs.Binds
-- others:
import TcEvidence
import CoreSyn
import DynFlags ( gopt, GeneralFlag(Opt_PrintExplicitCoercions) )
import Name
import NameSet
import BasicTypes
......@@ -186,9 +185,9 @@ instance Outputable SyntaxExprTc where
ppr (SyntaxExprTc { syn_expr = expr
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap })
= sdocWithDynFlags $ \ dflags ->
= sdocOption sdocPrintExplicitCoercions $ \print_co ->
getPprStyle $ \s ->
if debugStyle s || gopt Opt_PrintExplicitCoercions dflags
if debugStyle s || print_co
then ppr expr <> braces (pprWithCommas ppr arg_wraps)
<> braces (ppr res_wrap)
else ppr expr
......
......@@ -19,6 +19,7 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Hs.Pat (
Pat(..), InPat, OutPat, LPat,
......@@ -67,7 +68,6 @@ import Outputable
import Type
import SrcLoc
import Bag -- collect ev vars from pats
import DynFlags( gopt, GeneralFlag(..) )
import Maybes
-- libraries:
import Data.Data hiding (TyCon,Fixity)
......@@ -498,13 +498,13 @@ pprParendLPat p = pprParendPat p . unLoc
pprParendPat :: (OutputableBndrId p)
=> PprPrec -> Pat (GhcPass p) -> SDoc
pprParendPat p pat = sdocWithDynFlags $ \ dflags ->
if need_parens dflags pat
pprParendPat p pat = sdocOption sdocPrintTypecheckerElaboration $ \print_tc_elab ->
if need_parens print_tc_elab pat
then parens (pprPat pat)
else pprPat pat
where
need_parens dflags pat
| CoPat {} <- pat = gopt Opt_PrintTypecheckerElaboration dflags
need_parens print_tc_elab pat
| CoPat {} <- pat = print_tc_elab
| otherwise = patNeedsParens p pat
-- For a CoPat we need parens if we are going to show it, which
-- we do if -fprint-typechecker-elaboration is on (c.f. pprHsWrapper)
......@@ -551,16 +551,15 @@ pprPat (ConPatOut { pat_con = con
, pat_dicts = dicts
, pat_binds = binds
, pat_args = details })
= sdocWithDynFlags $ \dflags ->
-- Tiresome; in TcBinds.tcRhs we print out a
-- typechecked Pat in an error message,
-- and we want to make sure it prints nicely
if gopt Opt_PrintTypecheckerElaboration dflags then
ppr con
<> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
, pprIfTc @p $ ppr binds ])
<+> pprConArgs details
else pprUserCon (unLoc con) details
= sdocOption sdocPrintTypecheckerElaboration $ \case
False -> pprUserCon (unLoc con) details
True -> -- Tiresome; in TcBinds.tcRhs we print out a
-- typechecked Pat in an error message,
-- and we want to make sure it prints nicely
ppr con
<> braces (sep [ hsep (map pprPatBndr (tvs ++ dicts))
, pprIfTc @p $ ppr binds ])
<+> pprConArgs details
pprPat (XPat n) = noExtCon n
......
......@@ -1191,12 +1191,11 @@ levPolyPrimopErr expr_doc ty bad_tys
= errDs $ vcat
[ hang (text "Cannot use function with levity-polymorphic arguments:")
2 (expr_doc <+> dcolon <+> pprWithTYPE ty)
, sdocWithDynFlags $ \dflags ->
if not (gopt Opt_PrintTypecheckerElaboration dflags) then vcat
, ppUnlessOption sdocPrintTypecheckerElaboration $ vcat
[ text "(Note that levity-polymorphic primops such as 'coerce' and unboxed tuples"
, text "are eta-expanded internally because they must occur fully saturated."
, text "Use -fprint-typechecker-elaboration to display the full expression.)"
] else empty
]
, hang (text "Levity-polymorphic arguments:")
2 $ vcat $ map
(\t -> pprWithTYPE t <+> dcolon <+> pprWithTYPE (typeKind t))
......
......@@ -11,7 +11,7 @@ import DynFlags ( DynFlags )
import FastString ( FastString, mkFastString )
import GHC.Iface.Type
import Name hiding (varName)
import Outputable ( renderWithStyle, ppr, defaultUserStyle )
import Outputable ( renderWithStyle, ppr, defaultUserStyle, initSDocContext )
import SrcLoc
import GHC.CoreToIface
import TyCon
......@@ -44,7 +44,7 @@ generateReferencesMap = foldr (\ast m -> M.unionWith (++) (go ast) m) M.empty
this = fmap (pure . (nodeSpan ast,)) $ nodeIdentifiers $ nodeInfo ast
renderHieType :: DynFlags -> HieTypeFix -> String
renderHieType df ht = renderWithStyle df (ppr $ hieTypeToIface ht) sty
renderHieType df ht = renderWithStyle (initSDocContext df sty) (ppr $ hieTypeToIface ht)
where sty = defaultUserStyle df
resolveVisibility :: Type -> [Type] -> [(Bool,Type)]
......
......@@ -47,7 +47,6 @@ import GhcPrelude
import GHC.Iface.Type
import BinFingerprint
import CoreSyn( IsOrphan, isOrphan )
import DynFlags( gopt, GeneralFlag (Opt_PrintAxiomIncomps) )
import Demand
import Cpr
import Class
......@@ -610,14 +609,13 @@ pprAxBranch pp_tc idx (IfaceAxBranch { ifaxbTyVars = tvs
-- See Note [Displaying axiom incompatibilities]
maybe_index
= sdocWithDynFlags $ \dflags ->
ppWhen (gopt Opt_PrintAxiomIncomps dflags) $
= ppWhenOption sdocPrintAxiomIncomps $
text "{-" <+> (text "#" <> ppr idx) <+> text "-}"
maybe_incomps
= sdocWithDynFlags $ \dflags ->
ppWhen (gopt Opt_PrintAxiomIncomps dflags && notNull incomps) $
text "--" <+> text "incompatible with:"
<+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps
= ppWhenOption sdocPrintAxiomIncomps $
ppWhen (notNull incomps) $
text "--" <+> text "incompatible with:"
<+> pprWithCommas (\incomp -> text "#" <> ppr incomp) incomps
instance Outputable IfaceAnnotation where
ppr (IfaceAnnotation target value) = ppr target <+> colon <+> ppr value
......@@ -963,9 +961,9 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name,
ifPatProvCtxt = prov_ctxt, ifPatReqCtxt = req_ctxt,
ifPatArgs = arg_tys,
ifPatTy = pat_ty} )
= sdocWithDynFlags mk_msg
= sdocWithContext mk_msg
where
mk_msg dflags
mk_msg sdocCtx
= hang (text "pattern" <+> pprPrefixOcc name)
2 (dcolon <+> sep [univ_msg
, pprIfaceContextArr req_ctxt
......@@ -978,7 +976,7 @@ pprIfaceDecl _ (IfacePatSyn { ifName = name,
ex_msg = pprUserIfaceForAll ex_bndrs
insert_empty_ctxt = null req_ctxt
&& not (null prov_ctxt && isEmpty dflags ex_msg)
&& not (null prov_ctxt && isEmpty sdocCtx ex_msg)
pprIfaceDecl ss (IfaceId { ifName = var, ifType = ty,
ifIdDetails = details, ifIdInfo = info })
......@@ -1001,8 +999,8 @@ pprCType (Just cType) = text "C type:" <+> ppr cType
pprRoles :: (Role -> Bool) -> SDoc -> [IfaceTyConBinder]
-> [Role] -> SDoc
pprRoles suppress_if tyCon bndrs roles
= sdocWithDynFlags $ \dflags ->
let froles = suppressIfaceInvisibles dflags bndrs roles
= sdocOption sdocPrintExplicitKinds $ \print_kinds ->
let froles = suppressIfaceInvisibles (PrintExplicitKinds print_kinds) bndrs roles
in ppUnless (all suppress_if froles || null froles) $
text "type role" <+> tyCon <+> hsep (map ppr froles)
......@@ -1064,11 +1062,11 @@ pprIfaceDeclHead :: SuppressBndrSig
-> [IfaceTyConBinder] -- of the tycon, for invisible-suppression
-> SDoc
pprIfaceDeclHead suppress_sig context ss tc_occ bndrs
= sdocWithDynFlags $ \ dflags ->
= sdocOption sdocPrintExplicitKinds $ \print_kinds ->
sep [ pprIfaceContextArr context
, pprPrefixIfDeclBndr (ss_how_much ss) (occName tc_occ)
<+> pprIfaceTyConBinders suppress_sig
(suppressIfaceInvisibles dflags bndrs bndrs) ]
(suppressIfaceInvisibles (PrintExplicitKinds print_kinds) bndrs bndrs) ]
pprIfaceConDecl :: ShowSub -> Bool
-> IfaceTopBndr
......
......@@ -39,6 +39,7 @@ module GHC.Iface.Type (
-- Printing
SuppressBndrSig(..),
UseBndrParens(..),
PrintExplicitKinds(..),
pprIfaceType, pprParendIfaceType, pprPrecIfaceType,
pprIfaceContext, pprIfaceContextArr,
pprIfaceIdBndr, pprIfaceLamBndr, pprIfaceTvBndr, pprIfaceTyConBinders,
......@@ -65,7 +66,6 @@ import {-# SOURCE #-} TysWiredIn ( coercibleTyCon, heqTyCon
, liftedRepDataConTyCon, tupleTyConName )
import {-# SOURCE #-} Type ( isRuntimeRepTy )
import DynFlags
import TyCon hiding ( pprPromotionQuote )
import CoAxiom
import Var
......@@ -422,10 +422,9 @@ splitIfaceSigmaTy ty
= case split_rho ty2 of { (ps, tau) -> (ty1:ps, tau) }
split_rho tau = ([], tau)
suppressIfaceInvisibles :: DynFlags -> [IfaceTyConBinder] -> [a] -> [a]
suppressIfaceInvisibles dflags tys xs
| gopt Opt_PrintExplicitKinds dflags = xs
| otherwise = suppress tys xs
suppressIfaceInvisibles :: PrintExplicitKinds -> [IfaceTyConBinder] -> [a] -> [a]
suppressIfaceInvisibles (PrintExplicitKinds True) _tys xs = xs
suppressIfaceInvisibles (PrintExplicitKinds False) tys xs = suppress tys xs
where
suppress _ [] = []
suppress [] a = a
......@@ -433,10 +432,10 @@ suppressIfaceInvisibles dflags tys xs
| isInvisibleTyConBinder k = suppress ks xs
| otherwise = x : suppress ks xs
stripIfaceInvisVars :: DynFlags -> [IfaceTyConBinder] -> [IfaceTyConBinder]
stripIfaceInvisVars dflags tyvars
| gopt Opt_PrintExplicitKinds dflags = tyvars
| otherwise = filterOut isInvisibleTyConBinder tyvars
stripIfaceInvisVars :: PrintExplicitKinds -> [IfaceTyConBinder] -> [IfaceTyConBinder]
stripIfaceInvisVars (PrintExplicitKinds True) tyvars = tyvars
stripIfaceInvisVars (PrintExplicitKinds False) tyvars
= filterOut isInvisibleTyConBinder tyvars
-- | Extract an 'IfaceBndr' from an 'IfaceForAllBndr'.
ifForAllBndrVar :: IfaceForAllBndr -> IfaceBndr
......@@ -555,10 +554,9 @@ substIfaceTyVar env tv
************************************************************************
-}
stripInvisArgs :: DynFlags -> IfaceAppArgs -> IfaceAppArgs
stripInvisArgs dflags tys
| gopt Opt_PrintExplicitKinds dflags = tys
| otherwise = suppress_invis tys
stripInvisArgs :: PrintExplicitKinds -> IfaceAppArgs -> IfaceAppArgs
stripInvisArgs (PrintExplicitKinds True) tys = tys
stripInvisArgs (PrintExplicitKinds False) tys = suppress_invis tys
where
suppress_invis c
= case c of
......@@ -691,10 +689,9 @@ if_print_coercions :: SDoc -- ^ if printing coercions
-> SDoc -- ^ otherwise
-> SDoc
if_print_coercions yes no
= sdocWithDynFlags $ \dflags ->
= sdocOption sdocPrintExplicitCoercions $ \print_co ->
getPprStyle $ \style ->
if gopt Opt_PrintExplicitCoercions dflags
|| dumpStyle style || debugStyle style
if print_co || dumpStyle style || debugStyle style
then yes
else no
......@@ -757,7 +754,8 @@ Here we'd like to omit the kind annotation:
-- See Note [Suppressing binder signatures]
newtype SuppressBndrSig = SuppressBndrSig Bool
newtype UseBndrParens = UseBndrParens Bool
newtype UseBndrParens = UseBndrParens Bool
newtype PrintExplicitKinds = PrintExplicitKinds Bool
pprIfaceTvBndr :: IfaceTvBndr -> SuppressBndrSig -> UseBndrParens -> SDoc
pprIfaceTvBndr (tv, ki) (SuppressBndrSig suppress_sig) (UseBndrParens use_parens)
......@@ -857,12 +855,13 @@ ppr_ty ctxt_prec (IfaceAppTy t ts)
ppr_app_ty_no_casts
where
ppr_app_ty =
sdocWithDynFlags $ \dflags ->
pprIfacePrefixApp ctxt_prec
(ppr_ty funPrec t)
(map (ppr_app_arg appPrec) (tys_wo_kinds dflags))
sdocOption sdocPrintExplicitKinds $ \print_kinds ->
let tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs
(PrintExplicitKinds print_kinds) ts
in pprIfacePrefixApp ctxt_prec
(ppr_ty funPrec t)
(map (ppr_app_arg appPrec) tys_wo_kinds)
tys_wo_kinds dflags = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags ts
-- Strip any casts from the head of the application
ppr_app_ty_no_casts =
......@@ -1013,9 +1012,9 @@ defaultRuntimeRepVars ty = go False emptyFsEnv ty
eliminateRuntimeRep :: (IfaceType -> SDoc) -> IfaceType -> SDoc
eliminateRuntimeRep f ty
= sdocWithDynFlags $ \dflags ->
= sdocOption sdocPrintExplicitRuntimeReps $ \printExplicitRuntimeReps ->
getPprStyle $ \sty ->
if userStyle sty && not (gopt Opt_PrintExplicitRuntimeReps dflags)
if userStyle sty && not printExplicitRuntimeReps
then f (defaultRuntimeRepVars ty)
else f ty
......@@ -1036,9 +1035,8 @@ ppr_app_args ctx_prec = go
-- See Note [Pretty-printing invisible arguments]
ppr_app_arg :: PprPrec -> (IfaceType, ArgFlag) -> SDoc
ppr_app_arg ctx_prec (t, argf) =
sdocWithDynFlags $ \dflags ->
let print_kinds = gopt Opt_PrintExplicitKinds dflags
in case argf of
sdocOption sdocPrintExplicitKinds $ \print_kinds ->
case argf of
Required -> ppr_ty ctx_prec t
Specified | print_kinds
-> char '@' <> ppr_ty appPrec t
......@@ -1135,11 +1133,11 @@ pprIfaceSigmaType show_forall ty
pprUserIfaceForAll :: [IfaceForAllBndr] -> SDoc
pprUserIfaceForAll tvs
= sdocWithDynFlags $ \dflags ->
= sdocOption sdocPrintExplicitForalls $ \print_foralls ->
-- See Note [When to print foralls] in this module.
ppWhen (any tv_has_kind_var tvs
|| any tv_is_required tvs
|| gopt Opt_PrintExplicitForalls dflags) $
|| print_foralls) $
pprIfaceForAll tvs
where
tv_has_kind_var (Bndr (IfaceTvBndr (_,kind)) _)
......@@ -1286,13 +1284,13 @@ pprIfaceTypeApp prec tc args = pprTyTcApp prec tc args
pprTyTcApp :: PprPrec -> IfaceTyCon -> IfaceAppArgs -> SDoc
pprTyTcApp ctxt_prec tc tys =
sdocWithDynFlags $ \dflags ->
sdocOption sdocPrintExplicitKinds $ \print_kinds ->
getPprStyle $ \style ->
pprTyTcApp' ctxt_prec tc tys dflags style
pprTyTcApp' ctxt_prec tc tys (PrintExplicitKinds print_kinds) style
pprTyTcApp' :: PprPrec -> IfaceTyCon -> IfaceAppArgs
-> DynFlags -> PprStyle -> SDoc
pprTyTcApp' ctxt_prec tc tys dflags style
-> PrintExplicitKinds -> PprStyle -> SDoc
pprTyTcApp' ctxt_prec tc tys printExplicitKinds style
| ifaceTyConName tc `hasKey` ipClassKey
, IA_Arg (IfaceLitTy (IfaceStrTyLit n))
Required (IA_Arg ty Required IA_Nil) <- tys
......@@ -1308,7 +1306,7 @@ pprTyTcApp' ctxt_prec tc tys dflags style
= pprSum arity (ifaceTyConIsPromoted info) tys
| tc `ifaceTyConHasKey` consDataConKey
, not (gopt Opt_PrintExplicitKinds dflags)
, PrintExplicitKinds False <- printExplicitKinds
, IA_Arg _ argf (IA_Arg ty1 Required (IA_Arg ty2 Required IA_Nil)) <- tys
, isInvisibleArgFlag argf
= pprIfaceTyList ctxt_prec ty1 ty2
......@@ -1331,15 +1329,13 @@ pprTyTcApp' ctxt_prec tc tys dflags style
-> ppr_iface_tc_app ppr_app_arg ctxt_prec tc tys_wo_kinds
where
info = ifaceTyConInfo tc
tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs dflags tys
tys_wo_kinds = appArgsIfaceTypesArgFlags $ stripInvisArgs printExplicitKinds tys
ppr_kind_type :: PprPrec -> SDoc
ppr_kind_type ctxt_prec =
sdocWithDynFlags $ \dflags ->
if useStarIsType dflags
then maybeParen ctxt_prec starPrec $
unicodeSyntax (char '★') (char '*')
else text "Type"
ppr_kind_type ctxt_prec = sdocOption sdocStarIsType $ \case
False -> text "Type"
True -> maybeParen ctxt_prec starPrec $
unicodeSyntax (char '★') (char '*')
-- | Pretty-print a type-level equality.
-- Returns (Just doc) if the argument is a /saturated/ application
......@@ -1382,11 +1378,13 @@ ppr_equality ctxt_prec tc args
nominal_eq_tc = tc_name `hasKey` heqTyConKey -- (~~)
|| tc_name `hasKey` eqPrimTyConKey -- (~#)
print_equality args =
sdocWithDynFlags $ \dflags ->
sdocOption sdocPrintExplicitKinds $ \print_kinds ->
sdocOption sdocPrintEqualityRelations $ \print_eqs ->
getPprStyle $ \style ->
print_equality' args style dflags
print_equality' args print_kinds
(print_eqs || dumpStyle style || debugStyle style)
print_equality' (ki1, ki2, ty1, ty2) style dflags
print_equality' (ki1, ki2, ty1, ty2) print_kinds print_eqs
| -- If -fprint-equality-relations is on, just print the original TyCon
print_eqs
= ppr_infix_eq (ppr tc)
......@@ -1421,10 +1419,6 @@ ppr_equality ctxt_prec tc args
| otherwise
= pp opPrec ty
print_kinds = gopt Opt_PrintExplicitKinds dflags
print_eqs = gopt Opt_PrintEqualityRelations dflags ||
dumpStyle style || debugStyle style
pprIfaceCoTcApp :: PprPrec -> IfaceTyCon -> [IfaceCoercion] -> SDoc
pprIfaceCoTcApp ctxt_prec tc tys =
......
......@@ -87,9 +87,8 @@ ppLlvmGlobal (LMGlobal var@(LMGlobalVar _ _ link x a c) dat) =
in ppAssignment var $ ppr link <+> text const <+> rhs <> sect <> align
$+$ newLine
ppLlvmGlobal (LMGlobal var val) = sdocWithDynFlags $ \dflags ->
error $ "Non Global var ppr as global! "
++ showSDoc dflags (ppr var) ++ " " ++ showSDoc dflags (ppr val)
ppLlvmGlobal (LMGlobal var val) = pprPanic "ppLlvmGlobal" $
text "Non Global var ppr as global! " <> ppr var <> text "=" <> ppr val
-- | Print out a list of LLVM type aliases.
......
......@@ -196,9 +196,9 @@ pprStaticArith s1 s2 int_op float_op op_name =
op = if isFloat ty1 then float_op else int_op
in if ty1 == getStatType s2
then ppr ty1 <+> ptext op <+> lparen <> ppr s1 <> comma <> ppr s2 <> rparen
else sdocWithDynFlags $ \dflags ->
error $ op_name ++ " with different types! s1: "
++ showSDoc dflags (ppr s1) ++ ", s2: " ++ showSDoc dflags (ppr s2)
else pprPanic "pprStaticArith" $
text op_name <> text " with different types! s1: " <> ppr s1
<> text", s2: " <> ppr s2
-- -----------------------------------------------------------------------------
-- ** Operations on LLVM Basic Types and Variables
......@@ -228,8 +228,7 @@ ppLit (LMIntLit i (LMInt 64)) = ppr (fromInteger i :: Int64)
ppLit (LMIntLit i _ ) = ppr ((fromInteger i)::Int)
ppLit (LMFloatLit r LMFloat ) = ppFloat $ narrowFp r
ppLit (LMFloatLit r LMDouble) = ppDouble r
ppLit f@(LMFloatLit _ _) = sdocWithDynFlags (\dflags ->
error $ "Can't print this float literal!" ++ showSDoc dflags (ppr f))
ppLit f@(LMFloatLit _ _) = pprPanic "ppLit" (text "Can't print this float literal: " <> ppr f)
ppLit (LMVectorLit ls ) = char '<' <+> ppCommaJoin ls <+> char '>'
ppLit (LMNullLit _ ) = text "null"
-- #11487 was an issue where we passed undef for some arguments
......
......@@ -18,6 +18,7 @@ generation.
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE LambdaCase #-}
module GHC.Stg.Syntax (
StgArg(..),
......@@ -756,10 +757,9 @@ pprStgExpr (StgLetNoEscape ext bind expr)
2 (ppr expr)]
pprStgExpr (StgTick tickish expr)
= sdocWithDynFlags $ \dflags ->
if gopt Opt_SuppressTicks dflags
then pprStgExpr expr
else sep [ ppr tickish, pprStgExpr expr ]
= sdocOption sdocSuppressTicks $ \case
True -> pprStgExpr expr
False -> sep [ ppr tickish, pprStgExpr expr ]
-- Don't indent for a single case alternative.
......@@ -804,8 +804,7 @@ pprStgRhs :: OutputablePass pass => GenStgRhs pass -> SDoc
pprStgRhs (StgRhsClosure ext cc upd_flag args body)
= sdocWithDynFlags $ \dflags ->
hang (hsep [if gopt Opt_SccProfilingOn dflags then ppr cc else empty,
if not $ gopt Opt_SuppressStgExts dflags
then ppr ext else empty,
ppUnlessOption sdocSuppressStgExts (ppr ext),
char '\\' <> ppr upd_flag, brackets (interppSP args)])
4 (ppr body)
......
......@@ -538,8 +538,9 @@ msgUnitId pk = do
dflags <- getDynFlags
level <- getBkpLevel
liftIO . backpackProgressMsg level dflags
$ "Instantiating " ++ renderWithStyle dflags (ppr pk)
(backpackStyle dflags)
$ "Instantiating " ++ renderWithStyle
(initSDocContext dflags (backpackStyle dflags))
(ppr pk)
-- | Message when we include a Backpack unit.
msgInclude :: (Int,Int) -> UnitId -> BkpM ()
......@@ -548,7 +549,8 @@ msgInclude (i,n) uid = do
level <- getBkpLevel
liftIO . backpackProgressMsg level dflags
$ showModuleIndex (i, n) ++ "Including " ++
renderWithStyle dflags (ppr uid) (backpackStyle dflags)
renderWithStyle (initSDocContext dflags (backpackStyle dflags))
(ppr uid)
-- ----------------------------------------------------------------------------
-- Conversion from PackageName to HsComponentId
......
......@@ -90,7 +90,6 @@ import Unique
import Util
import Maybes
import Binary
import DynFlags
import FastString
import Outputable
......@@ -561,10 +560,8 @@ pprExternal sty uniq mod occ is_wired is_builtin
_ -> braces (ppr (moduleName mod) <> dot <> ppr_occ_name occ)
else pprModulePrefix sty mod occ <> ppr_occ_name occ
where
pp_mod = sdocWithDynFlags $ \dflags ->
if gopt Opt_SuppressModulePrefixes dflags
then empty
else ppr mod <> dot
pp_mod = ppUnlessOption sdocSuppressModulePrefixes
(ppr mod <> dot)
pprInternal :: PprStyle -> Unique -> OccName -> SDoc
pprInternal sty uniq occ
......@@ -591,10 +588,7 @@ pprSystem sty uniq occ
pprModulePrefix :: PprStyle -> Module -> OccName -> SDoc
-- Print the "M." part of a name, based on whether it's in scope or not
-- See Note [Printing original names] in HscTypes
pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags ->