summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorSylvain Henry <sylvain@haskus.fr>2020-02-03 17:57:29 +0100
committerMarge Bot <ben+marge-bot@smart-cactus.org>2020-02-20 21:18:48 -0500
commit6880d6aa1e6e96579bbff89712efd813489cc828 (patch)
treef2156d5a5c168bf28ee569a62a74b51adf74dac9
parent74ad75e87317196c600dfabc61aee1b87d95c214 (diff)
downloadhaskell-6880d6aa1e6e96579bbff89712efd813489cc828.tar.gz
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
Diffstat
-rw-r--r--compiler/GHC/Cmm/Ppr.hs22
-rw-r--r--compiler/GHC/Cmm/Ppr/Expr.hs15
-rw-r--r--compiler/GHC/CmmToLlvm/Base.hs8
-rw-r--r--compiler/GHC/CmmToLlvm/CodeGen.hs2
-rw-r--r--compiler/GHC/Hs/Binds.hs29
-rw-r--r--compiler/GHC/Hs/Expr.hs5
-rw-r--r--compiler/GHC/Hs/Pat.hs29
-rw-r--r--compiler/GHC/HsToCore/Expr.hs5
-rw-r--r--compiler/GHC/Iface/Ext/Utils.hs4
-rw-r--r--compiler/GHC/Iface/Syntax.hs26
-rw-r--r--compiler/GHC/Iface/Type.hs90
-rw-r--r--compiler/GHC/Llvm/Ppr.hs5
-rw-r--r--compiler/GHC/Llvm/Types.hs9
-rw-r--r--compiler/GHC/Stg/Syntax.hs11
-rw-r--r--compiler/backpack/DriverBkp.hs8
-rw-r--r--compiler/basicTypes/Name.hs22
-rw-r--r--compiler/basicTypes/OccName.hs9
-rw-r--r--compiler/basicTypes/RdrName.hs10
-rw-r--r--compiler/basicTypes/Var.hs5
-rw-r--r--compiler/coreSyn/PprCore.hs109
-rw-r--r--compiler/main/DynFlags.hs68
-rw-r--r--compiler/main/DynFlags.hs-boot6
-rw-r--r--compiler/main/ErrUtils.hs35
-rw-r--r--compiler/nativeGen/AsmCodeGen.hs4
-rw-r--r--compiler/nativeGen/Dwarf/Types.hs6
-rw-r--r--compiler/nativeGen/X86/Ppr.hs19
-rw-r--r--compiler/typecheck/TcBackpack.hs3
-rw-r--r--compiler/typecheck/TcErrors.hs35
-rw-r--r--compiler/typecheck/TcEvidence.hs9
-rw-r--r--compiler/typecheck/TcOrigin.hs17
-rw-r--r--compiler/typecheck/TcRnDriver.hs6
-rw-r--r--compiler/typecheck/TcRnDriver.hs-boot3
-rw-r--r--compiler/types/TyCoPpr.hs10
-rw-r--r--compiler/utils/Outputable.hs187
-rw-r--r--compiler/utils/Outputable.hs-boot2
35 files changed, 433 insertions, 400 deletions
diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs
index 891cbd9c6d..9f02cdcace 100644
--- a/compiler/GHC/Cmm/Ppr.hs
+++ b/compiler/GHC/Cmm/Ppr.hs
@@ -1,4 +1,5 @@
{-# 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 ->
diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs
index 53a335e561..fbd4cdb7f1 100644
--- a/compiler/GHC/Cmm/Ppr/Expr.hs
+++ b/compiler/GHC/Cmm/Ppr/Expr.hs
@@ -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")
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index c0bd742840..5cfef04029 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -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)
-- ----------------------------------------------------------------------------
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index 33dd82c418..947ba31f35 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -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
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs
index 2014d92c25..6796216c87 100644
--- a/compiler/GHC/Hs/Binds.hs
+++ b/compiler/GHC/Hs/Binds.hs
@@ -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
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 6890484472..308b112886 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -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
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 50db04e92e..3e78ec4fb9 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -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
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 0d927e4e59..f400a1fdf1 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -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))
diff --git a/compiler/GHC/Iface/Ext/Utils.hs b/compiler/GHC/Iface/Ext/Utils.hs
index b0d71f34b4..eba14f190a 100644
--- a/compiler/GHC/Iface/Ext/Utils.hs
+++ b/compiler/GHC/Iface/Ext/Utils.hs
@@ -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)]
diff --git a/compiler/GHC/Iface/Syntax.hs b/compiler/GHC/Iface/Syntax.hs
index 668ce1ec7b..c831d09c7f 100644
--- a/compiler/GHC/Iface/Syntax.hs
+++ b/compiler/GHC/Iface/Syntax.hs
@@ -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
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index 3ff25ba20e..3c08262ed8 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -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 =
diff --git a/compiler/GHC/Llvm/Ppr.hs b/compiler/GHC/Llvm/Ppr.hs
index 0e8d279a50..092dec39fb 100644
--- a/compiler/GHC/Llvm/Ppr.hs
+++ b/compiler/GHC/Llvm/Ppr.hs
@@ -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.
diff --git a/compiler/GHC/Llvm/Types.hs b/compiler/GHC/Llvm/Types.hs
index f4fa9a9a56..61c2b2cb86 100644
--- a/compiler/GHC/Llvm/Types.hs
+++ b/compiler/GHC/Llvm/Types.hs
@@ -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
diff --git a/compiler/GHC/Stg/Syntax.hs b/compiler/GHC/Stg/Syntax.hs
index 5c57722a42..5f52784cb8 100644
--- a/compiler/GHC/Stg/Syntax.hs
+++ b/compiler/GHC/Stg/Syntax.hs
@@ -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)
diff --git a/compiler/backpack/DriverBkp.hs b/compiler/backpack/DriverBkp.hs
index ec2700b070..ee4d9fb5e4 100644
--- a/compiler/backpack/DriverBkp.hs
+++ b/compiler/backpack/DriverBkp.hs
@@ -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
diff --git a/compiler/basicTypes/Name.hs b/compiler/basicTypes/Name.hs
index 341cc79bb6..2215a4d108 100644
--- a/compiler/basicTypes/Name.hs
+++ b/compiler/basicTypes/Name.hs
@@ -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 ->
- if gopt Opt_SuppressModulePrefixes dflags
- then empty
- else
+pprModulePrefix sty mod occ = ppUnlessOption sdocSuppressModulePrefixes $
case qualName sty mod occ of -- See Outputable.QualifyName:
NameQual modname -> ppr modname <> dot -- Name is in scope
NameNotInScope1 -> ppr mod <> dot -- Not in scope
@@ -605,17 +599,15 @@ pprModulePrefix sty mod occ = sdocWithDynFlags $ \dflags ->
pprUnique :: Unique -> SDoc
-- Print a unique unless we are suppressing them
pprUnique uniq
- = sdocWithDynFlags $ \dflags ->
- ppUnless (gopt Opt_SuppressUniques dflags) $
- pprUniqueAlways uniq
+ = ppUnlessOption sdocSuppressUniques $
+ pprUniqueAlways uniq
ppr_underscore_unique :: Unique -> SDoc
-- Print an underscore separating the name from its unique
-- But suppress it if we aren't printing the uniques anyway
ppr_underscore_unique uniq
- = sdocWithDynFlags $ \dflags ->
- ppUnless (gopt Opt_SuppressUniques dflags) $
- char '_' <> pprUniqueAlways uniq
+ = ppUnlessOption sdocSuppressUniques $
+ char '_' <> pprUniqueAlways uniq
ppr_occ_name :: OccName -> SDoc
ppr_occ_name occ = ftext (occNameFS occ)
diff --git a/compiler/basicTypes/OccName.hs b/compiler/basicTypes/OccName.hs
index ac2ad47100..3a45cf87dd 100644
--- a/compiler/basicTypes/OccName.hs
+++ b/compiler/basicTypes/OccName.hs
@@ -6,6 +6,7 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
-- |
-- #name_types#
@@ -104,7 +105,6 @@ import GhcPrelude
import Util
import Unique
-import DynFlags
import UniqFM
import UniqSet
import FastString
@@ -278,10 +278,9 @@ pprOccName (OccName sp occ)
pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp)
| otherwise = empty
- pp_occ = sdocWithDynFlags $ \dflags ->
- if gopt Opt_SuppressUniques dflags
- then text (strip_th_unique (unpackFS occ))
- else ftext occ
+ pp_occ = sdocOption sdocSuppressUniques $ \case
+ True -> text (strip_th_unique (unpackFS occ))
+ False -> ftext occ
-- See Note [Suppressing uniques in OccNames]
strip_th_unique ('[' : c : _) | isAlphaNum c = []
diff --git a/compiler/basicTypes/RdrName.hs b/compiler/basicTypes/RdrName.hs
index 42628ad516..d20462c0b3 100644
--- a/compiler/basicTypes/RdrName.hs
+++ b/compiler/basicTypes/RdrName.hs
@@ -1376,12 +1376,12 @@ pprLoc (UnhelpfulSpan {}) = empty
--
starInfo :: Bool -> RdrName -> SDoc
starInfo star_is_type rdr_name =
- -- One might ask: if can use sdocWithDynFlags here, why bother to take
- -- star_is_type as input? Why not refactor?
+ -- One might ask: if can use `sdocOption sdocStarIsType` here, why bother to
+ -- take star_is_type as input? Why not refactor?
--
- -- The reason is that sdocWithDynFlags would provide DynFlags that are active
- -- in the module that tries to load the problematic definition, not
- -- in the module that is being loaded.
+ -- The reason is that `sdocOption sdocStarIsType` would indicate that
+ -- StarIsType is enabled in the module that tries to load the problematic
+ -- definition, not in the module that is being loaded.
--
-- So if we have 'data T :: *' in a module with NoStarIsType, then the hint
-- must be displayed even if we load this definition from a module (or GHCi)
diff --git a/compiler/basicTypes/Var.hs b/compiler/basicTypes/Var.hs
index e9926d799d..cadbe070a4 100644
--- a/compiler/basicTypes/Var.hs
+++ b/compiler/basicTypes/Var.hs
@@ -102,7 +102,6 @@ import Unique ( Uniquable, Unique, getKey, getUnique
, mkUniqueGrimily, nonDetCmpUnique )
import Util
import Binary
-import DynFlags
import Outputable
import Data.Data
@@ -300,9 +299,9 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds
-}
instance Outputable Var where
- ppr var = sdocWithDynFlags $ \dflags ->
+ ppr var = sdocOption sdocSuppressVarKinds $ \supp_var_kinds ->
getPprStyle $ \ppr_style ->
- if | debugStyle ppr_style && (not (gopt Opt_SuppressVarKinds dflags))
+ if | debugStyle ppr_style && (not supp_var_kinds)
-> parens (ppr (varName var) <+> ppr_debug var ppr_style <+>
dcolon <+> pprKind (tyVarKind var))
| otherwise
diff --git a/compiler/coreSyn/PprCore.hs b/compiler/coreSyn/PprCore.hs
index 6a08b4a442..760c325d2b 100644
--- a/compiler/coreSyn/PprCore.hs
+++ b/compiler/coreSyn/PprCore.hs
@@ -7,7 +7,9 @@ Printing of Core syntax
-}
{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
+
module PprCore (
pprCoreExpr, pprParendExpr,
pprCoreBinding, pprCoreBindings, pprCoreAlt,
@@ -30,7 +32,6 @@ import DataCon
import TyCon
import TyCoPpr
import Coercion
-import DynFlags
import BasicTypes
import Maybes
import Util
@@ -116,13 +117,11 @@ ppr_bind ann (Rec binds) = vcat (map pp binds)
ppr_binding :: OutputableBndr b => Annotation b -> (b, Expr b) -> SDoc
ppr_binding ann (val_bdr, expr)
- = sdocWithDynFlags $ \dflags ->
- vcat [ ann expr
- , if gopt Opt_SuppressTypeSignatures dflags
- then empty
- else pprBndr LetBind val_bdr
- , pp_bind
- ]
+ = vcat [ ann expr
+ , ppUnlessOption sdocSuppressTypeSignatures
+ (pprBndr LetBind val_bdr)
+ , pp_bind
+ ]
where
pp_bind = case bndrIsJoin_maybe val_bdr of
Nothing -> pp_normal_bind
@@ -156,10 +155,9 @@ noParens pp = pp
pprOptCo :: Coercion -> SDoc
-- Print a coercion optionally; i.e. honouring -dsuppress-coercions
-pprOptCo co = sdocWithDynFlags $ \dflags ->
- if gopt Opt_SuppressCoercions dflags
- then angleBrackets (text "Co:" <> int (coercionSize co))
- else parens (sep [ppr co, dcolon <+> ppr (coercionType co)])
+pprOptCo co = sdocOption sdocSuppressCoercions $ \case
+ True -> angleBrackets (text "Co:" <> int (coercionSize co))
+ False -> parens $ sep [ppr co, dcolon <+> ppr (coercionType co)]
ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
-- The function adds parens in context that need
@@ -184,15 +182,15 @@ ppr_expr add_par expr@(Lam _ _)
2 (pprCoreExpr body)
ppr_expr add_par expr@(App {})
- = sdocWithDynFlags $ \dflags ->
+ = sdocOption sdocSuppressTypeApplications $ \supp_ty_app ->
case collectArgs expr of { (fun, args) ->
let
pp_args = sep (map pprArg args)
val_args = dropWhile isTypeArg args -- Drop the type arguments for tuples
pp_tup_args = pprWithCommas pprCoreExpr val_args
args'
- | gopt Opt_SuppressTypeApplications dflags = val_args
- | otherwise = args
+ | supp_ty_app = val_args
+ | otherwise = args
parens
| null args' = id
| otherwise = add_par
@@ -217,27 +215,26 @@ ppr_expr add_par expr@(App {})
}
ppr_expr add_par (Case expr var ty [(con,args,rhs)])
- = sdocWithDynFlags $ \dflags ->
- if gopt Opt_PprCaseAsLet dflags
- then add_par $ -- See Note [Print case as let]
- sep [ sep [ text "let! {"
- <+> ppr_case_pat con args
- <+> text "~"
- <+> ppr_bndr var
- , text "<-" <+> ppr_expr id expr
- <+> text "} in" ]
- , pprCoreExpr rhs
- ]
- else add_par $
- sep [sep [sep [ text "case" <+> pprCoreExpr expr
- , whenPprDebug (text "return" <+> ppr ty)
- , text "of" <+> ppr_bndr var
- ]
- , char '{' <+> ppr_case_pat con args <+> arrow
- ]
- , pprCoreExpr rhs
- , char '}'
- ]
+ = sdocOption sdocPrintCaseAsLet $ \case
+ True -> add_par $ -- See Note [Print case as let]
+ sep [ sep [ text "let! {"
+ <+> ppr_case_pat con args
+ <+> text "~"
+ <+> ppr_bndr var
+ , text "<-" <+> ppr_expr id expr
+ <+> text "} in" ]
+ , pprCoreExpr rhs
+ ]
+ False -> add_par $
+ sep [sep [sep [ text "case" <+> pprCoreExpr expr
+ , whenPprDebug (text "return" <+> ppr ty)
+ , text "of" <+> ppr_bndr var
+ ]
+ , char '{' <+> ppr_case_pat con args <+> arrow
+ ]
+ , pprCoreExpr rhs
+ , char '}'
+ ]
where
ppr_bndr = pprBndr CaseBind
@@ -291,10 +288,9 @@ ppr_expr add_par (Let bind expr)
| otherwise = text "letrec"
ppr_expr add_par (Tick tickish expr)
- = sdocWithDynFlags $ \dflags ->
- if gopt Opt_SuppressTicks dflags
- then ppr_expr add_par expr
- else add_par (sep [ppr tickish, pprCoreExpr expr])
+ = sdocOption sdocSuppressTicks $ \case
+ True -> ppr_expr add_par expr
+ False -> add_par (sep [ppr tickish, pprCoreExpr expr])
pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc
pprCoreAlt (con, args, rhs)
@@ -317,10 +313,8 @@ ppr_case_pat con args
-- | Pretty print the argument in a function application.
pprArg :: OutputableBndr a => Expr a -> SDoc
pprArg (Type ty)
- = sdocWithDynFlags $ \dflags ->
- if gopt Opt_SuppressTypeApplications dflags
- then empty
- else text "@" <> pprParendType ty
+ = ppUnlessOption sdocSuppressTypeApplications
+ (text "@" <> pprParendType ty)
pprArg (Coercion co) = text "@~" <> pprOptCo co
pprArg expr = pprParendExpr expr
@@ -388,7 +382,7 @@ pprUntypedBinder binder
pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
-- For lambda and case binders, show the unfolding info (usually none)
pprTypedLamBinder bind_site debug_on var
- = sdocWithDynFlags $ \dflags ->
+ = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs ->
case () of
_
| not debug_on -- Show case-bound wild binders only if debug is on
@@ -405,7 +399,7 @@ pprTypedLamBinder bind_site debug_on var
| not debug_on
, CasePatBind <- bind_site -> pprUntypedBinder var
- | suppress_sigs dflags -> pprUntypedBinder var
+ | suppress_sigs -> pprUntypedBinder var
| isTyVar var -> parens (pprKindedTyVarBndr var)
@@ -413,8 +407,6 @@ pprTypedLamBinder bind_site debug_on var
2 (vcat [ dcolon <+> pprType (idType var)
, pp_unf]))
where
- suppress_sigs = gopt Opt_SuppressTypeSignatures
-
unf_info = unfoldingInfo (idInfo var)
pp_unf | hasSomeUnfolding unf_info = text "Unf=" <> ppr unf_info
| otherwise = empty
@@ -422,12 +414,12 @@ pprTypedLamBinder bind_site debug_on var
pprTypedLetBinder :: Var -> SDoc
-- Print binder with a type or kind signature (not paren'd)
pprTypedLetBinder binder
- = sdocWithDynFlags $ \dflags ->
+ = sdocOption sdocSuppressTypeSignatures $ \suppress_sigs ->
case () of
_
- | isTyVar binder -> pprKindedTyVarBndr binder
- | gopt Opt_SuppressTypeSignatures dflags -> pprIdBndr binder
- | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
+ | isTyVar binder -> pprKindedTyVarBndr binder
+ | suppress_sigs -> pprIdBndr binder
+ | otherwise -> hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
pprKindedTyVarBndr :: TyVar -> SDoc
-- Print a type variable binder with its kind (but not if *)
@@ -441,9 +433,8 @@ pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
pprIdBndrInfo :: IdInfo -> SDoc
pprIdBndrInfo info
- = sdocWithDynFlags $ \dflags ->
- ppUnless (gopt Opt_SuppressIdInfo dflags) $
- info `seq` doc -- The seq is useful for poking on black holes
+ = ppUnlessOption sdocSuppressIdInfo
+ (info `seq` doc) -- The seq is useful for poking on black holes
where
prag_info = inlinePragInfo info
occ_info = occInfo info
@@ -514,8 +505,7 @@ instance Outputable IdInfo where
ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo id info
- = sdocWithDynFlags $ \dflags ->
- ppUnless (gopt Opt_SuppressIdInfo dflags) $
+ = ppUnlessOption sdocSuppressIdInfo $
showAttributes
[ (True, pp_scope <> ppr (idDetails id))
, (has_arity, text "Arity=" <> int arity)
@@ -606,9 +596,8 @@ instance Outputable Unfolding where
, text "WorkFree=" <> ppr wf
, text "Expandable=" <> ppr exp
, text "Guidance=" <> ppr g ]
- pp_tmpl = sdocWithDynFlags $ \dflags ->
- ppUnless (gopt Opt_SuppressUnfoldings dflags) $
- text "Tmpl=" <+> ppr rhs
+ pp_tmpl = ppUnlessOption sdocSuppressUnfoldings
+ (text "Tmpl=" <+> ppr rhs)
pp_rhs | isStableSource src = pp_tmpl
| otherwise = empty
-- Don't print the RHS or we get a quadratic
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index f5e2fd93aa..97bc2fece1 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -38,8 +38,6 @@ module DynFlags (
xopt, xopt_set, xopt_unset,
xopt_set_unlessExplSpec,
lang_set,
- useUnicodeSyntax,
- useStarIsType,
whenGeneratingDynamicToo, ifGeneratingDynamicToo,
whenCannotGenerateDynamicToo,
dynamicTooMkDynamicDynFlags,
@@ -62,8 +60,6 @@ module DynFlags (
wWarningFlags,
dynFlagDependencies,
makeDynFlagsConsistent,
- shouldUseColor,
- shouldUseHexWordLiterals,
positionIndependent,
optimisationFlags,
setFlagsFromEnvFile,
@@ -241,6 +237,8 @@ module DynFlags (
-- * Include specifications
IncludeSpecs(..), addGlobalInclude, addQuoteInclude, flattenIncludes,
+ -- * SDoc
+ initSDocContext,
-- * Make use of the Cmm CFG
CfgWeights(..), backendMaintainsCfg
@@ -1707,13 +1705,6 @@ data RtsOptsEnabled
| RtsOptsAll
deriving (Show)
-shouldUseColor :: DynFlags -> Bool
-shouldUseColor dflags = overrideWith (canUseColor dflags) (useColor dflags)
-
-shouldUseHexWordLiterals :: DynFlags -> Bool
-shouldUseHexWordLiterals dflags =
- Opt_HexWordLiterals `EnumSet.member` generalFlags dflags
-
-- | Are we building with @-fPIE@ or @-fPIC@ enabled?
positionIndependent :: DynFlags -> Bool
positionIndependent dflags = gopt Opt_PIC dflags || gopt Opt_PIE dflags
@@ -1920,10 +1911,8 @@ initDynFlags dflags = do
do str' <- peekCString enc cstr
return (str == str'))
`catchIOError` \_ -> return False
- maybeGhcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE"
- let adjustNoUnicode (Just _) = False
- adjustNoUnicode Nothing = True
- let useUnicode' = (adjustNoUnicode maybeGhcNoUnicodeEnv) && canUseUnicode
+ ghcNoUnicodeEnv <- lookupEnv "GHC_NO_UNICODE"
+ let useUnicode' = isNothing ghcNoUnicodeEnv && canUseUnicode
canUseColor <- stderrSupportsAnsiColors
maybeGhcColorsEnv <- lookupEnv "GHC_COLORS"
maybeGhcColoursEnv <- lookupEnv "GHC_COLOURS"
@@ -2498,16 +2487,6 @@ lang_set dflags lang =
extensionFlags = flattenExtensionFlags lang (extensions dflags)
}
--- | An internal helper to check whether to use unicode syntax for output.
---
--- Note: You should very likely be using 'Outputable.unicodeSyntax' instead
--- of this function.
-useUnicodeSyntax :: DynFlags -> Bool
-useUnicodeSyntax = gopt Opt_PrintUnicodeSyntax
-
-useStarIsType :: DynFlags -> Bool
-useStarIsType = xopt LangExt.StarIsType
-
-- | Set the Haskell language standard to use
setLanguage :: Language -> DynP ()
setLanguage l = upd (`lang_set` Just l)
@@ -5918,3 +5897,42 @@ data FilesToClean = FilesToClean {
-- | An empty FilesToClean
emptyFilesToClean :: FilesToClean
emptyFilesToClean = FilesToClean Set.empty Set.empty
+
+
+
+initSDocContext :: DynFlags -> PprStyle -> SDocContext
+initSDocContext dflags style = SDC
+ { sdocStyle = style
+ , sdocColScheme = colScheme dflags
+ , sdocLastColour = Col.colReset
+ , sdocShouldUseColor = overrideWith (canUseColor dflags) (useColor dflags)
+ , sdocLineLength = pprCols dflags
+ , sdocCanUseUnicode = useUnicode dflags
+ , sdocHexWordLiterals = gopt Opt_HexWordLiterals dflags
+ , sdocDebugLevel = debugLevel dflags
+ , sdocPprDebug = dopt Opt_D_ppr_debug dflags
+ , sdocPrintUnicodeSyntax = gopt Opt_PrintUnicodeSyntax dflags
+ , sdocPrintCaseAsLet = gopt Opt_PprCaseAsLet dflags
+ , sdocPrintTypecheckerElaboration = gopt Opt_PrintTypecheckerElaboration dflags
+ , sdocPrintAxiomIncomps = gopt Opt_PrintAxiomIncomps dflags
+ , sdocPrintExplicitKinds = gopt Opt_PrintExplicitKinds dflags
+ , sdocPrintExplicitCoercions = gopt Opt_PrintExplicitCoercions dflags
+ , sdocPrintExplicitRuntimeReps = gopt Opt_PrintExplicitRuntimeReps dflags
+ , sdocPrintExplicitForalls = gopt Opt_PrintExplicitForalls dflags
+ , sdocPrintPotentialInstances = gopt Opt_PrintPotentialInstances dflags
+ , sdocPrintEqualityRelations = gopt Opt_PrintEqualityRelations dflags
+ , sdocSuppressTicks = gopt Opt_SuppressTicks dflags
+ , sdocSuppressTypeSignatures = gopt Opt_SuppressTypeSignatures dflags
+ , sdocSuppressTypeApplications = gopt Opt_SuppressTypeApplications dflags
+ , sdocSuppressIdInfo = gopt Opt_SuppressIdInfo dflags
+ , sdocSuppressCoercions = gopt Opt_SuppressCoercions dflags
+ , sdocSuppressUnfoldings = gopt Opt_SuppressUnfoldings dflags
+ , sdocSuppressVarKinds = gopt Opt_SuppressVarKinds dflags
+ , sdocSuppressUniques = gopt Opt_SuppressUniques dflags
+ , sdocSuppressModulePrefixes = gopt Opt_SuppressModulePrefixes dflags
+ , sdocSuppressStgExts = gopt Opt_SuppressStgExts dflags
+ , sdocErrorSpans = gopt Opt_ErrorSpans dflags
+ , sdocStarIsType = xopt LangExt.StarIsType dflags
+ , sdocImpredicativeTypes = xopt LangExt.ImpredicativeTypes dflags
+ , sdocDynFlags = dflags
+ }
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
index 6f9bdc5138..6d471f3970 100644
--- a/compiler/main/DynFlags.hs-boot
+++ b/compiler/main/DynFlags.hs-boot
@@ -2,6 +2,7 @@ module DynFlags where
import GhcPrelude
import GHC.Platform
+import {-# SOURCE #-} Outputable
data DynFlags
data DumpFlag
@@ -11,9 +12,6 @@ targetPlatform :: DynFlags -> Platform
pprUserLength :: DynFlags -> Int
pprCols :: DynFlags -> Int
unsafeGlobalDynFlags :: DynFlags
-useUnicode :: DynFlags -> Bool
-useUnicodeSyntax :: DynFlags -> Bool
-shouldUseColor :: DynFlags -> Bool
-shouldUseHexWordLiterals :: DynFlags -> Bool
hasPprDebug :: DynFlags -> Bool
hasNoDebugOutput :: DynFlags -> Bool
+initSDocContext :: DynFlags -> PprStyle -> SDocContext
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index b5dab7ea35..320912ba59 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -8,6 +8,7 @@
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE LambdaCase #-}
module ErrUtils (
-- * Basic types
@@ -209,12 +210,12 @@ mkLocMessageAnn
-- are supposed to be in a standard format, and one without a location
-- would look strange. Better to say explicitly "<no location info>".
mkLocMessageAnn ann severity locn msg
- = sdocWithDynFlags $ \dflags ->
- let locn' = if gopt Opt_ErrorSpans dflags
- then ppr locn
- else ppr (srcSpanStart locn)
+ = sdocOption sdocColScheme $ \col_scheme ->
+ let locn' = sdocOption sdocErrorSpans $ \case
+ True -> ppr locn
+ False -> ppr (srcSpanStart locn)
- sevColour = getSeverityColour severity (colScheme dflags)
+ sevColour = getSeverityColour severity col_scheme
-- Add optional information
optAnn = case ann of
@@ -226,8 +227,8 @@ mkLocMessageAnn ann severity locn msg
header = locn' <> colon <+>
coloured sevColour sevText <> optAnn
- in coloured (Col.sMessage (colScheme dflags))
- (hang (coloured (Col.sHeader (colScheme dflags)) header) 4
+ in coloured (Col.sMessage col_scheme)
+ (hang (coloured (Col.sHeader col_scheme) header) 4
msg)
where
@@ -279,9 +280,9 @@ getCaretDiagnostic severity (RealSrcSpan span) = do
caretDiagnostic Nothing = empty
caretDiagnostic (Just srcLineWithNewline) =
- sdocWithDynFlags $ \ dflags ->
- let sevColour = getSeverityColour severity (colScheme dflags)
- marginColour = Col.sMargin (colScheme dflags)
+ sdocOption sdocColScheme$ \col_scheme ->
+ let sevColour = getSeverityColour severity col_scheme
+ marginColour = Col.sMargin col_scheme
in
coloured marginColour (text marginSpace) <>
text ("\n") <>
@@ -377,7 +378,8 @@ warningsToMessages dflags =
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
= sequence_ [ let style = mkErrStyle dflags unqual
- in putLogMsg dflags reason sev s style (formatErrDoc dflags doc)
+ ctx = initSDocContext dflags style
+ in putLogMsg dflags reason sev s style (formatErrDoc ctx doc)
| ErrMsg { errMsgSpan = s,
errMsgDoc = doc,
errMsgSeverity = sev,
@@ -385,13 +387,13 @@ printBagOfErrors dflags bag_of_errors
errMsgContext = unqual } <- sortMsgBag (Just dflags)
bag_of_errors ]
-formatErrDoc :: DynFlags -> ErrDoc -> SDoc
-formatErrDoc dflags (ErrDoc important context supplementary)
+formatErrDoc :: SDocContext -> ErrDoc -> SDoc
+formatErrDoc ctx (ErrDoc important context supplementary)
= case msgs of
[msg] -> vcat msg
_ -> vcat $ map starred msgs
where
- msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty dflags))
+ msgs = filter (not . null) $ map (filter (not . Outputable.isEmpty ctx))
[important, context, supplementary]
starred = (bullet<+>) . vcat
@@ -403,9 +405,8 @@ pprLocErrMsg (ErrMsg { errMsgSpan = s
, errMsgDoc = doc
, errMsgSeverity = sev
, errMsgContext = unqual })
- = sdocWithDynFlags $ \dflags ->
- withPprStyle (mkErrStyle dflags unqual) $
- mkLocMessage sev s (formatErrDoc dflags doc)
+ = sdocWithContext $ \ctx ->
+ withErrStyle unqual $ mkLocMessage sev s (formatErrDoc ctx doc)
sortMsgBag :: Maybe DynFlags -> Bag ErrMsg -> [ErrMsg]
sortMsgBag dflags = maybeLimit . sortBy (maybeFlip cmp) . bagToList
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/nativeGen/AsmCodeGen.hs
index 88f666c375..4653deaab6 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/nativeGen/AsmCodeGen.hs
@@ -888,7 +888,9 @@ makeImportsDoc dflags imports
| otherwise
= Outputable.empty
- doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel dflags lbl) astyle)
+ doPpr lbl = (lbl, renderWithStyle
+ (initSDocContext dflags astyle)
+ (pprCLabel dflags lbl))
astyle = mkCodeStyle AsmStyle
-- -----------------------------------------------------------------------------
diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/nativeGen/Dwarf/Types.hs
index df578e2671..c006081872 100644
--- a/compiler/nativeGen/Dwarf/Types.hs
+++ b/compiler/nativeGen/Dwarf/Types.hs
@@ -177,7 +177,7 @@ pprDwarfInfoOpen _ (DwarfSubprogram _ name label
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev abbrev
$$ pprString name
- $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+ $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
$$ pprFlag (externallyVisibleCLabel label)
$$ pprWord (ppr label)
$$ pprWord (ppr $ mkAsmTempEndLabel label)
@@ -192,11 +192,11 @@ pprDwarfInfoOpen _ (DwarfSubprogram _ name label
pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlockWithoutCode
- $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+ $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlock
- $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+ $$ pprString (renderWithStyle (initSDocContext df (mkCodeStyle CStyle)) (ppr label))
$$ pprWord (ppr marker)
$$ pprWord (ppr $ mkAsmTempEndLabel marker)
pprDwarfInfoOpen _ (DwarfSrcNote ss) =
diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs
index 8b73cdffc1..4df7287b5a 100644
--- a/compiler/nativeGen/X86/Ppr.hs
+++ b/compiler/nativeGen/X86/Ppr.hs
@@ -120,15 +120,17 @@ pprSizeDecl lbl
pprBasicBlock :: LabelMap RawCmmStatics -> NatBasicBlock Instr -> SDoc
pprBasicBlock info_env (BasicBlock blockid instrs)
- = sdocWithDynFlags $ \dflags ->
- maybe_infotable dflags $
+ = maybe_infotable $
pprLabel asmLbl $$
vcat (map pprInstr instrs) $$
- (if debugLevel dflags > 0
- then ppr (mkAsmTempEndLabel asmLbl) <> char ':' else empty)
+ (sdocOption sdocDebugLevel $ \level ->
+ if level > 0
+ then ppr (mkAsmTempEndLabel asmLbl) <> char ':'
+ else empty
+ )
where
asmLbl = blockLbl blockid
- maybe_infotable dflags c = case mapLookup blockid info_env of
+ maybe_infotable c = case mapLookup blockid info_env of
Nothing -> c
Just (RawCmmStatics infoLbl info) ->
pprAlignForSection Text $$
@@ -136,8 +138,11 @@ pprBasicBlock info_env (BasicBlock blockid instrs)
vcat (map pprData info) $$
pprLabel infoLbl $$
c $$
- (if debugLevel dflags > 0
- then ppr (mkAsmTempEndLabel infoLbl) <> char ':' else empty)
+ (sdocOption sdocDebugLevel $ \level ->
+ if level > 0
+ then ppr (mkAsmTempEndLabel infoLbl) <> char ':'
+ else empty
+ )
-- Make sure the info table has the right .loc for the block
-- coming right after it. See [Note: Info Offset]
infoTableLoc = case instrs of
diff --git a/compiler/typecheck/TcBackpack.hs b/compiler/typecheck/TcBackpack.hs
index 29f5e616df..93de957b27 100644
--- a/compiler/typecheck/TcBackpack.hs
+++ b/compiler/typecheck/TcBackpack.hs
@@ -168,9 +168,8 @@ checkHsigIface tcg_env gr sig_iface
-- info for the *specific* name we matched.
-> getLoc e
_ -> nameSrcSpan name
- dflags <- getDynFlags
addErrAt loc
- (badReexportedBootThing dflags False name name')
+ (badReexportedBootThing False name name')
-- This should actually never happen, but whatever...
| otherwise =
addErrAt (nameSrcSpan name)
diff --git a/compiler/typecheck/TcErrors.hs b/compiler/typecheck/TcErrors.hs
index 3fd70d0a2b..24aea54adb 100644
--- a/compiler/typecheck/TcErrors.hs
+++ b/compiler/typecheck/TcErrors.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -1196,10 +1197,8 @@ mkHoleError tidy_simples ctxt ct@(CHoleCan { cc_occ = occ, cc_hole = hole_sort }
MetaTv {} -> quotes (ppr tv) <+> text "is an ambiguous type variable"
_ -> empty -- Skolems dealt with already
| otherwise -- A coercion variable can be free in the hole type
- = sdocWithDynFlags $ \dflags ->
- if gopt Opt_PrintExplicitCoercions dflags
- then quotes (ppr tv) <+> text "is a coercion variable"
- else empty
+ = ppWhenOption sdocPrintExplicitCoercions $
+ quotes (ppr tv) <+> text "is a coercion variable"
mkHoleError _ _ ct = pprPanic "mkHoleError" (ppr ct)
@@ -1353,10 +1352,10 @@ mkEqErr1 ctxt ct -- Wanted or derived;
where
sub_what = case sub_t_or_k of Just KindLevel -> text "kinds"
_ -> text "types"
- msg1 = sdocWithDynFlags $ \dflags ->
+ msg1 = sdocOption sdocPrintExplicitCoercions $ \printExplicitCoercions ->
case mb_cty2 of
Just cty2
- | gopt Opt_PrintExplicitCoercions dflags
+ | printExplicitCoercions
|| not (cty1 `pickyEqType` cty2)
-> hang (text "When matching" <+> sub_what)
2 (vcat [ ppr cty1 <+> dcolon <+>
@@ -1921,10 +1920,9 @@ mkExpectedActualMsg ty1 ty2 ct@(TypeEqOrigin { uo_actual = act
-- TYPE t0
| Just arg <- kindRep_maybe exp
- , tcIsTyVarTy arg = sdocWithDynFlags $ \dflags ->
- if gopt Opt_PrintExplicitRuntimeReps dflags
- then text "kind" <+> quotes (ppr exp)
- else text "a type"
+ , tcIsTyVarTy arg = sdocOption sdocPrintExplicitRuntimeReps $ \case
+ True -> text "kind" <+> quotes (ppr exp)
+ False -> text "a type"
| otherwise = text "kind" <+> quotes (ppr exp)
@@ -2347,9 +2345,9 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
potential_msg
= ppWhen (not (null unifiers) && want_potential orig) $
- sdocWithDynFlags $ \dflags ->
+ sdocOption sdocPrintPotentialInstances $ \print_insts ->
getPprStyle $ \sty ->
- pprPotentials dflags sty potential_hdr unifiers
+ pprPotentials (PrintPotentialInstances print_insts) sty potential_hdr unifiers
potential_hdr
= vcat [ ppWhen lead_with_ambig $
@@ -2408,9 +2406,9 @@ mk_dict_err ctxt@(CEC {cec_encl = implics}) (ct, (matches, unifiers, unsafe_over
sep [text "Matching givens (or their superclasses):"
, nest 2 (vcat matching_givens)]
- , sdocWithDynFlags $ \dflags ->
+ , sdocOption sdocPrintPotentialInstances $ \print_insts ->
getPprStyle $ \sty ->
- pprPotentials dflags sty (text "Matching instances:") $
+ pprPotentials (PrintPotentialInstances print_insts) sty (text "Matching instances:") $
ispecs ++ unifiers
, ppWhen (null matching_givens && isSingleton matches && null unifiers) $
@@ -2599,9 +2597,13 @@ show_fixes [] = empty
show_fixes (f:fs) = sep [ text "Possible fix:"
, nest 2 (vcat (f : map (text "or" <+>) fs))]
-pprPotentials :: DynFlags -> PprStyle -> SDoc -> [ClsInst] -> SDoc
+
+-- Avoid boolean blindness
+newtype PrintPotentialInstances = PrintPotentialInstances Bool
+
+pprPotentials :: PrintPotentialInstances -> PprStyle -> SDoc -> [ClsInst] -> SDoc
-- See Note [Displaying potential instances]
-pprPotentials dflags sty herald insts
+pprPotentials (PrintPotentialInstances show_potentials) sty herald insts
| null insts
= empty
@@ -2620,7 +2622,6 @@ pprPotentials dflags sty herald insts
, flag_hint ])
where
n_show = 3 :: Int
- show_potentials = gopt Opt_PrintPotentialInstances dflags
(in_scope, not_in_scope) = partition inst_in_scope insts
sorted = sortBy fuzzyClsInstCmp in_scope
diff --git a/compiler/typecheck/TcEvidence.hs b/compiler/typecheck/TcEvidence.hs
index f60405e8be..fb6fa71ada 100644
--- a/compiler/typecheck/TcEvidence.hs
+++ b/compiler/typecheck/TcEvidence.hs
@@ -1,6 +1,7 @@
-- (c) The University of Glasgow 2006
{-# LANGUAGE CPP, DeriveDataTypeable #-}
+{-# LANGUAGE LambdaCase #-}
module TcEvidence (
@@ -64,7 +65,6 @@ import TyCon
import DataCon( DataCon, dataConWrapId )
import Class( Class )
import PrelNames
-import DynFlags ( gopt, GeneralFlag(Opt_PrintTypecheckerElaboration) )
import VarEnv
import VarSet
import Predicate
@@ -912,10 +912,9 @@ pprHsWrapper :: HsWrapper -> (Bool -> SDoc) -> SDoc
-- The pp_thing_inside function takes Bool to say whether
-- it's in a position that needs parens for a non-atomic thing
pprHsWrapper wrap pp_thing_inside
- = sdocWithDynFlags $ \ dflags ->
- if gopt Opt_PrintTypecheckerElaboration dflags
- then help pp_thing_inside wrap False
- else pp_thing_inside False
+ = sdocOption sdocPrintTypecheckerElaboration $ \case
+ True -> help pp_thing_inside wrap False
+ False -> pp_thing_inside False
where
help :: (Bool -> SDoc) -> HsWrapper -> Bool -> SDoc
-- True <=> appears in function application position
diff --git a/compiler/typecheck/TcOrigin.hs b/compiler/typecheck/TcOrigin.hs
index df7a39f72e..c69013917c 100644
--- a/compiler/typecheck/TcOrigin.hs
+++ b/compiler/typecheck/TcOrigin.hs
@@ -6,6 +6,7 @@ The datatypes here are mainly used for error message generation.
-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -42,8 +43,6 @@ import PatSyn
import Module
import Name
import RdrName
-import qualified GHC.LanguageExtensions as LangExt
-import DynFlags
import SrcLoc
import FastString
@@ -608,13 +607,13 @@ pprCtOrigin (FailablePattern pat)
text "(this will become an error in a future GHC release)"
pprCtOrigin (Shouldn'tHappenOrigin note)
- = sdocWithDynFlags $ \dflags ->
- if xopt LangExt.ImpredicativeTypes dflags
- then text "a situation created by impredicative types"
- else
- vcat [ text "<< This should not appear in error messages. If you see this"
- , text "in an error message, please report a bug mentioning" <+> quotes (text note) <+> text "at"
- , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>" ]
+ = sdocOption sdocImpredicativeTypes $ \case
+ True -> text "a situation created by impredicative types"
+ False -> vcat [ text "<< This should not appear in error messages. If you see this"
+ , text "in an error message, please report a bug mentioning"
+ <+> quotes (text note) <+> text "at"
+ , text "https://gitlab.haskell.org/ghc/ghc/wikis/report-a-bug >>"
+ ]
pprCtOrigin (ProvCtxtOrigin PSB{ psb_id = (L _ name) })
= hang (ctoHerald <+> text "the \"provided\" constraints claimed by")
diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs
index 2caee7df9f..8d8d135d71 100644
--- a/compiler/typecheck/TcRnDriver.hs
+++ b/compiler/typecheck/TcRnDriver.hs
@@ -1321,9 +1321,9 @@ missingBootThing is_boot name what
<+> text "file, but not"
<+> text what <+> text "the module"
-badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc
-badReexportedBootThing dflags is_boot name name'
- = withPprStyle (mkUserStyle dflags alwaysQualify AllTheWay) $ vcat
+badReexportedBootThing :: Bool -> Name -> Name -> SDoc
+badReexportedBootThing is_boot name name'
+ = withUserStyle alwaysQualify AllTheWay $ vcat
[ text "The" <+> (if is_boot then text "hs-boot" else text "hsig")
<+> text "file (re)exports" <+> quotes (ppr name)
, text "but the implementing module exports a different identifier" <+> quotes (ppr name')
diff --git a/compiler/typecheck/TcRnDriver.hs-boot b/compiler/typecheck/TcRnDriver.hs-boot
index 6ffc409e22..cdbdca50af 100644
--- a/compiler/typecheck/TcRnDriver.hs-boot
+++ b/compiler/typecheck/TcRnDriver.hs-boot
@@ -1,7 +1,6 @@
module TcRnDriver where
import GhcPrelude
-import DynFlags (DynFlags)
import Type (TyThing)
import TcRnTypes (TcM)
import Outputable (SDoc)
@@ -10,4 +9,4 @@ import Name (Name)
checkBootDeclM :: Bool -- ^ True <=> an hs-boot file (could also be a sig)
-> TyThing -> TyThing -> TcM ()
missingBootThing :: Bool -> Name -> String -> SDoc
-badReexportedBootThing :: DynFlags -> Bool -> Name -> Name -> SDoc
+badReexportedBootThing :: Bool -> Name -> Name -> SDoc
diff --git a/compiler/types/TyCoPpr.hs b/compiler/types/TyCoPpr.hs
index f7a768210b..e3581ba02a 100644
--- a/compiler/types/TyCoPpr.hs
+++ b/compiler/types/TyCoPpr.hs
@@ -49,8 +49,6 @@ import GHC.Iface.Type
import VarSet
import VarEnv
-import DynFlags ( gopt_set,
- GeneralFlag(Opt_PrintExplicitKinds, Opt_PrintExplicitRuntimeReps) )
import Outputable
import BasicTypes ( PprPrec(..), topPrec, sigPrec, opPrec
, funPrec, appPrec, maybeParen )
@@ -318,14 +316,14 @@ pprTypeApp tc tys
-- See @Note [Kind arguments in error messages]@ in TcErrors.
pprWithExplicitKindsWhen :: Bool -> SDoc -> SDoc
pprWithExplicitKindsWhen b
- = updSDocDynFlags $ \dflags ->
- if b then gopt_set dflags Opt_PrintExplicitKinds
- else dflags
+ = updSDocContext $ \ctx ->
+ if b then ctx { sdocPrintExplicitKinds = True }
+ else ctx
-- | This variant preserves any use of TYPE in a type, effectively
-- locally setting -fprint-explicit-runtime-reps.
pprWithTYPE :: Type -> SDoc
-pprWithTYPE ty = updSDocDynFlags (flip gopt_set Opt_PrintExplicitRuntimeReps) $
+pprWithTYPE ty = updSDocContext (\ctx -> ctx { sdocPrintExplicitRuntimeReps = True }) $
ppr ty
-- | Pretty prints a 'TyCon', using the family instance in case of a
diff --git a/compiler/utils/Outputable.hs b/compiler/utils/Outputable.hs
index 02805c6c7c..ba595757e9 100644
--- a/compiler/utils/Outputable.hs
+++ b/compiler/utils/Outputable.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE LambdaCase #-}
+
{-
(c) The University of Glasgow 2006-2012
(c) The GRASP Project, Glasgow University, 1992-1998
@@ -34,6 +36,7 @@ module Outputable (
sep, cat,
fsep, fcat,
hang, hangNotEmpty, punctuate, ppWhen, ppUnless,
+ ppWhenOption, ppUnlessOption,
speakNth, speakN, speakNOf, plural, isOrAre, doOrDoes, itsOrTheir,
unicodeSyntax,
@@ -68,14 +71,16 @@ module Outputable (
neverQualify, neverQualifyNames, neverQualifyModules,
alwaysQualifyPackages, neverQualifyPackages,
QualifyName(..), queryQual,
- sdocWithDynFlags, sdocWithPlatform,
- updSDocDynFlags,
- getPprStyle, withPprStyle, withPprStyleDoc, setStyleColoured,
+ sdocWithDynFlags, sdocWithPlatform, sdocOption,
+ updSDocContext,
+ SDocContext (..), sdocWithContext,
+ getPprStyle, withPprStyle, setStyleColoured,
pprDeeper, pprDeeperList, pprSetDepth,
codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
qualName, qualModule, qualPackage,
mkErrStyle, defaultErrStyle, defaultDumpStyle, mkDumpStyle, defaultUserStyle,
mkUserStyle, cmdlineParserStyle, Depth(..),
+ withUserStyle, withErrStyle,
ifPprDebug, whenPprDebug, getPprDebug,
@@ -91,9 +96,8 @@ import GhcPrelude
import {-# SOURCE #-} DynFlags( DynFlags, hasPprDebug, hasNoDebugOutput,
targetPlatform, pprUserLength, pprCols,
- useUnicode, useUnicodeSyntax,
- shouldUseColor, unsafeGlobalDynFlags,
- shouldUseHexWordLiterals )
+ unsafeGlobalDynFlags,
+ initSDocContext)
import {-# SOURCE #-} Module( UnitId, Module, ModuleName, moduleName )
import {-# SOURCE #-} OccName( OccName )
@@ -281,6 +285,16 @@ mkUserStyle dflags unqual depth
| hasPprDebug dflags = PprDebug
| otherwise = 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
+
+withErrStyle :: PrintUnqualified -> SDoc -> SDoc
+withErrStyle unqual doc =
+ sdocWithDynFlags $ \dflags ->
+ withPprStyle (mkErrStyle dflags unqual) doc
+
setStyleColoured :: Bool -> PprStyle -> PprStyle
setStyleColoured col style =
case style of
@@ -320,10 +334,43 @@ code (either C or assembly), or generating interface files.
newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc }
data SDocContext = SDC
- { sdocStyle :: !PprStyle
- , sdocLastColour :: !Col.PprColour
- -- ^ The most recently used colour. This allows nesting colours.
- , sdocDynFlags :: !DynFlags
+ { sdocStyle :: !PprStyle
+ , sdocColScheme :: !Col.Scheme
+ , sdocLastColour :: !Col.PprColour
+ -- ^ The most recently used colour.
+ -- This allows nesting colours.
+ , sdocShouldUseColor :: !Bool
+ , sdocLineLength :: !Int
+ , sdocCanUseUnicode :: !Bool
+ -- ^ True if Unicode encoding is supported
+ -- and not disable by GHC_NO_UNICODE environment variable
+ , sdocHexWordLiterals :: !Bool
+ , sdocDebugLevel :: !Int
+ , sdocPprDebug :: !Bool
+ , sdocPrintUnicodeSyntax :: !Bool
+ , sdocPrintCaseAsLet :: !Bool
+ , sdocPrintTypecheckerElaboration :: !Bool
+ , sdocPrintAxiomIncomps :: !Bool
+ , sdocPrintExplicitKinds :: !Bool
+ , sdocPrintExplicitCoercions :: !Bool
+ , sdocPrintExplicitRuntimeReps :: !Bool
+ , sdocPrintExplicitForalls :: !Bool
+ , sdocPrintPotentialInstances :: !Bool
+ , sdocPrintEqualityRelations :: !Bool
+ , sdocSuppressTicks :: !Bool
+ , sdocSuppressTypeSignatures :: !Bool
+ , sdocSuppressTypeApplications :: !Bool
+ , sdocSuppressIdInfo :: !Bool
+ , sdocSuppressCoercions :: !Bool
+ , sdocSuppressUnfoldings :: !Bool
+ , sdocSuppressVarKinds :: !Bool
+ , sdocSuppressUniques :: !Bool
+ , sdocSuppressModulePrefixes :: !Bool
+ , sdocSuppressStgExts :: !Bool
+ , sdocErrorSpans :: !Bool
+ , sdocStarIsType :: !Bool
+ , sdocImpredicativeTypes :: !Bool
+ , sdocDynFlags :: DynFlags -- TODO: remove
}
instance IsString SDoc where
@@ -333,22 +380,10 @@ instance IsString SDoc where
instance Outputable SDoc where
ppr = id
-initSDocContext :: DynFlags -> PprStyle -> SDocContext
-initSDocContext dflags sty = SDC
- { sdocStyle = sty
- , sdocLastColour = Col.colReset
- , sdocDynFlags = dflags
- }
withPprStyle :: PprStyle -> SDoc -> SDoc
withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
--- | This is not a recommended way to render 'SDoc', since it breaks the
--- abstraction layer of 'SDoc'. Prefer to use 'printSDoc', 'printSDocLn',
--- 'bufLeftRenderSDoc', or 'renderWithStyle' instead.
-withPprStyleDoc :: DynFlags -> PprStyle -> SDoc -> Doc
-withPprStyleDoc dflags sty d = runSDoc d (initSDocContext dflags sty)
-
pprDeeper :: SDoc -> SDoc
pprDeeper d = SDoc $ \ctx -> case ctx of
SDC{sdocStyle=PprUser _ (PartWay 0) _} -> Pretty.text "..."
@@ -389,9 +424,15 @@ sdocWithDynFlags f = SDoc $ \ctx -> runSDoc (f (sdocDynFlags ctx)) ctx
sdocWithPlatform :: (Platform -> SDoc) -> SDoc
sdocWithPlatform f = sdocWithDynFlags (f . targetPlatform)
-updSDocDynFlags :: (DynFlags -> DynFlags) -> SDoc -> SDoc
-updSDocDynFlags upd doc
- = SDoc $ \ctx -> runSDoc doc (ctx { sdocDynFlags = upd (sdocDynFlags ctx) })
+sdocWithContext :: (SDocContext -> SDoc) -> SDoc
+sdocWithContext f = SDoc $ \ctx -> runSDoc (f ctx) ctx
+
+sdocOption :: (SDocContext -> a) -> (a -> SDoc) -> SDoc
+sdocOption f g = sdocWithContext (g . f)
+
+updSDocContext :: (SDocContext -> SDocContext) -> SDoc -> SDoc
+updSDocContext upd doc
+ = SDoc $ \ctx -> runSDoc doc (upd ctx)
qualName :: PprStyle -> QueryQualifyName
qualName (PprUser q _ _) mod occ = queryQualifyName q mod occ
@@ -495,7 +536,7 @@ mkCodeStyle = PprCode
-- However, Doc *is* an instance of Show
-- showSDoc just blasts it out as a string
showSDoc :: DynFlags -> SDoc -> String
-showSDoc dflags sdoc = renderWithStyle dflags sdoc (defaultUserStyle dflags)
+showSDoc dflags sdoc = renderWithStyle (initSDocContext dflags (defaultUserStyle dflags)) sdoc
-- showSDocUnsafe is unsafe, because `unsafeGlobalDynFlags` might not be
-- initialised yet.
@@ -512,19 +553,19 @@ showSDocUnqual dflags sdoc = showSDoc dflags sdoc
showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
-- Allows caller to specify the PrintUnqualified to use
showSDocForUser dflags unqual doc
- = renderWithStyle dflags doc (mkUserStyle dflags unqual AllTheWay)
+ = renderWithStyle (initSDocContext dflags (mkUserStyle dflags unqual AllTheWay)) doc
showSDocDump :: DynFlags -> SDoc -> String
-showSDocDump dflags d = renderWithStyle dflags d (defaultDumpStyle dflags)
+showSDocDump dflags d = renderWithStyle (initSDocContext dflags (defaultDumpStyle dflags)) d
showSDocDebug :: DynFlags -> SDoc -> String
-showSDocDebug dflags d = renderWithStyle dflags d PprDebug
+showSDocDebug dflags d = renderWithStyle (initSDocContext dflags PprDebug) d
-renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
-renderWithStyle dflags sdoc sty
- = let s = Pretty.style{ Pretty.mode = PageMode,
- Pretty.lineLength = pprCols dflags }
- in Pretty.renderStyle s $ runSDoc sdoc (initSDocContext dflags sty)
+renderWithStyle :: SDocContext -> SDoc -> String
+renderWithStyle ctx sdoc
+ = let s = Pretty.style{ Pretty.mode = PageMode,
+ Pretty.lineLength = sdocLineLength ctx }
+ in Pretty.renderStyle s $ runSDoc sdoc ctx
-- This shows an SDoc, but on one line only. It's cheaper than a full
-- showSDoc, designed for when we're getting results like "Foo.bar"
@@ -547,9 +588,8 @@ irrelevantNCols :: Int
-- Used for OneLineMode and LeftMode when number of cols isn't used
irrelevantNCols = 1
-isEmpty :: DynFlags -> SDoc -> Bool
-isEmpty dflags sdoc = Pretty.isEmpty $ runSDoc sdoc dummySDocContext
- where dummySDocContext = initSDocContext dflags PprDebug
+isEmpty :: SDocContext -> SDoc -> Bool
+isEmpty ctx sdoc = Pretty.isEmpty $ runSDoc sdoc (ctx {sdocStyle = PprDebug})
docToSDoc :: Doc -> SDoc
docToSDoc d = SDoc (\_ -> d)
@@ -581,11 +621,10 @@ integer n = docToSDoc $ Pretty.integer n
float n = docToSDoc $ Pretty.float n
double n = docToSDoc $ Pretty.double n
rational n = docToSDoc $ Pretty.rational n
-word n = sdocWithDynFlags $ \dflags ->
- -- See Note [Print Hexadecimal Literals] in Pretty.hs
- if shouldUseHexWordLiterals dflags
- then docToSDoc $ Pretty.hex n
- else docToSDoc $ Pretty.integer n
+ -- See Note [Print Hexadecimal Literals] in Pretty.hs
+word n = sdocOption sdocHexWordLiterals $ \case
+ True -> docToSDoc $ Pretty.hex n
+ False -> docToSDoc $ Pretty.integer n
-- | @doublePrec p n@ shows a floating point number @n@ with @p@
-- digits of precision after the decimal point.
@@ -608,17 +647,15 @@ cparen b d = SDoc $ Pretty.maybeParens b . runSDoc d
-- 'quotes' encloses something in single quotes...
-- but it omits them if the thing begins or ends in a single quote
-- so that we don't get `foo''. Instead we just have foo'.
-quotes d =
- sdocWithDynFlags $ \dflags ->
- if useUnicode dflags
- then char '‘' <> d <> char '’'
- else SDoc $ \sty ->
- let pp_d = runSDoc d sty
- str = show pp_d
- in case (str, lastMaybe str) of
- (_, Just '\'') -> pp_d
- ('\'' : _, _) -> pp_d
- _other -> Pretty.quotes pp_d
+quotes d = sdocOption sdocCanUseUnicode $ \case
+ True -> char '‘' <> d <> char '’'
+ False -> SDoc $ \sty ->
+ let pp_d = runSDoc d sty
+ str = show pp_d
+ in case (str, lastMaybe str) of
+ (_, Just '\'') -> pp_d
+ ('\'' : _, _) -> pp_d
+ _other -> Pretty.quotes pp_d
semi, comma, colon, equals, space, dcolon, underscore, dot, vbar :: SDoc
arrow, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt :: SDoc
@@ -655,16 +692,17 @@ bullet :: SDoc
bullet = unicode (char '•') (char '*')
unicodeSyntax :: SDoc -> SDoc -> SDoc
-unicodeSyntax unicode plain = sdocWithDynFlags $ \dflags ->
- if useUnicode dflags && useUnicodeSyntax dflags
+unicodeSyntax unicode plain =
+ sdocOption sdocCanUseUnicode $ \can_use_unicode ->
+ sdocOption sdocPrintUnicodeSyntax $ \print_unicode_syntax ->
+ if can_use_unicode && print_unicode_syntax
then unicode
else plain
unicode :: SDoc -> SDoc -> SDoc
-unicode unicode plain = sdocWithDynFlags $ \dflags ->
- if useUnicode dflags
- then unicode
- else plain
+unicode unicode plain = sdocOption sdocCanUseUnicode $ \case
+ True -> unicode
+ False -> plain
nest :: Int -> SDoc -> SDoc
-- ^ Indent 'SDoc' some specified amount
@@ -737,22 +775,29 @@ ppWhen False _ = empty
ppUnless True _ = empty
ppUnless False doc = doc
+ppWhenOption :: (SDocContext -> Bool) -> SDoc -> SDoc
+ppWhenOption f doc = sdocOption f $ \case
+ True -> doc
+ False -> empty
+
+ppUnlessOption :: (SDocContext -> Bool) -> SDoc -> SDoc
+ppUnlessOption f doc = sdocOption f $ \case
+ True -> empty
+ False -> doc
+
-- | Apply the given colour\/style for the argument.
--
-- Only takes effect if colours are enabled.
coloured :: Col.PprColour -> SDoc -> SDoc
-coloured col sdoc =
- sdocWithDynFlags $ \dflags ->
- if shouldUseColor dflags
- then SDoc $ \ctx@SDC{ sdocLastColour = lastCol } ->
- case ctx of
- SDC{ sdocStyle = PprUser _ _ Coloured } ->
- let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in
- Pretty.zeroWidthText (Col.renderColour col)
- Pretty.<> runSDoc sdoc ctx'
- Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol)
- _ -> runSDoc sdoc ctx
- else sdoc
+coloured col sdoc = sdocOption sdocShouldUseColor $ \case
+ True -> SDoc $ \case
+ ctx@SDC{ sdocLastColour = lastCol, sdocStyle = PprUser _ _ Coloured } ->
+ let ctx' = ctx{ sdocLastColour = lastCol `mappend` col } in
+ Pretty.zeroWidthText (Col.renderColour col)
+ Pretty.<> runSDoc sdoc ctx'
+ Pretty.<> Pretty.zeroWidthText (Col.renderColourAfresh lastCol)
+ ctx -> runSDoc sdoc ctx
+ False -> sdoc
keyword :: SDoc -> SDoc
keyword = coloured Col.colBold
diff --git a/compiler/utils/Outputable.hs-boot b/compiler/utils/Outputable.hs-boot
index fb3c173a33..77e0982826 100644
--- a/compiler/utils/Outputable.hs-boot
+++ b/compiler/utils/Outputable.hs-boot
@@ -4,6 +4,8 @@ import GhcPrelude
import GHC.Stack( HasCallStack )
data SDoc
+data PprStyle
+data SDocContext
showSDocUnsafe :: SDoc -> String
View Lorry Controller Status