Commit f89ce062 authored by ian@well-typed.com's avatar ian@well-typed.com

Make the -dsuppress-* flags dynamic

parent ef786b6c
......@@ -88,7 +88,7 @@ import Unique
import Util
import Maybes
import Binary
import StaticFlags
import DynFlags
import FastTypes
import FastString
import Outputable
......@@ -465,8 +465,10 @@ pprExternal sty uniq mod occ name is_wired is_builtin
| BuiltInSyntax <- is_builtin = ppr_occ_name occ -- Never qualify builtin syntax
| otherwise = pprModulePrefix sty mod name <> ppr_occ_name occ
where
pp_mod | opt_SuppressModulePrefixes = empty
| otherwise = ppr mod <> dot
pp_mod = sdocWithDynFlags $ \dflags ->
if dopt Opt_SuppressModulePrefixes dflags
then empty
else ppr mod <> dot
pprInternal :: PprStyle -> Unique -> OccName -> SDoc
pprInternal sty uniq occ
......@@ -493,11 +495,11 @@ pprSystem sty uniq occ
pprModulePrefix :: PprStyle -> Module -> Name -> 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 name
| opt_SuppressModulePrefixes = empty
| otherwise
= case qualName sty name of -- See Outputable.QualifyName:
pprModulePrefix sty mod name = sdocWithDynFlags $ \dflags ->
if dopt Opt_SuppressModulePrefixes dflags
then empty
else
case qualName sty name of -- See Outputable.QualifyName:
NameQual modname -> ppr modname <> dot -- Name is in scope
NameNotInScope1 -> ppr mod <> dot -- Not in scope
NameNotInScope2 -> ppr (modulePackageId mod) <> colon -- Module not in
......@@ -508,8 +510,10 @@ 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
| opt_SuppressUniques = empty
| otherwise = char '_' <> pprUnique uniq
= sdocWithDynFlags $ \dflags ->
if dopt Opt_SuppressUniques dflags
then empty
else char '_' <> pprUnique uniq
ppr_occ_name :: OccName -> SDoc
ppr_occ_name occ = ftext (occNameFS occ)
......
......@@ -109,12 +109,12 @@ module OccName (
import Util
import Unique
import BasicTypes
import DynFlags
import UniqFM
import UniqSet
import FastString
import Outputable
import Binary
import StaticFlags( opt_SuppressUniques )
import Data.Char
import Data.Data
\end{code}
......@@ -271,8 +271,10 @@ pprOccName (OccName sp occ)
pp_debug sty | debugStyle sty = braces (pprNameSpaceBrief sp)
| otherwise = empty
pp_occ | opt_SuppressUniques = text (strip_th_unique (unpackFS occ))
| otherwise = ftext occ
pp_occ = sdocWithDynFlags $ \dflags ->
if dopt Opt_SuppressUniques dflags
then text (strip_th_unique (unpackFS occ))
else ftext occ
-- See Note [Suppressing uniques in OccNames]
strip_th_unique ('[' : c : _) | isAlphaNum c = []
......
......@@ -86,8 +86,6 @@ import FastTypes
import FastString
import Outputable
-- import StaticFlags ( opt_SuppressVarKinds )
import Data.Data
\end{code}
......@@ -217,7 +215,7 @@ After CoreTidy, top-level LocalIds are turned into GlobalIds
instance Outputable Var where
ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
-- Printing the type on every occurrence is too much!
-- <+> if (not opt_SuppressVarKinds)
-- <+> if (not (dopt Opt_SuppressVarKinds dflags))
-- then ifPprDebug (text "::" <+> ppr (tyVarKind var) <+> text ")")
-- else empty
......
......@@ -25,7 +25,6 @@ import TyCon
import Type
import Coercion
import DynFlags
import StaticFlags
import BasicTypes
import Util
import Outputable
......@@ -119,9 +118,11 @@ ppr_expr add_par (Cast expr co)
sep [pprParendExpr expr,
ptext (sLit "`cast`") <+> pprCo co]
where
pprCo co | opt_SuppressCoercions = ptext (sLit "...")
| otherwise = parens
$ sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
pprCo co = sdocWithDynFlags $ \dflags ->
if dopt Opt_SuppressCoercions dflags
then ptext (sLit "...")
else parens $
sep [ppr co, dcolon <+> pprEqPred (coercionKind co)]
ppr_expr add_par expr@(Lam _ _)
......@@ -250,8 +251,10 @@ ppr_case_pat con args
-- | Pretty print the argument in a function application.
pprArg :: OutputableBndr a => Expr a -> SDoc
pprArg (Type ty)
| opt_SuppressTypeApplications = empty
| otherwise = ptext (sLit "@") <+> pprParendType ty
= sdocWithDynFlags $ \dflags ->
if dopt Opt_SuppressTypeApplications dflags
then empty
else ptext (sLit "@") <+> pprParendType ty
pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
pprArg expr = pprParendExpr expr
\end{code}
......@@ -284,12 +287,18 @@ pprUntypedBinder binder
pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc
-- For lambda and case binders, show the unfolding info (usually none)
pprTypedLamBinder bind_site debug_on var
| not debug_on && isDeadBinder var = char '_'
| not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info
| opt_SuppressAll = pprUntypedBinder var -- Suppress the signature
| isTyVar var = parens (pprKindedTyVarBndr var)
| otherwise = parens (hang (pprIdBndr var)
2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
= sdocWithDynFlags $ \dflags ->
case () of
_
| not debug_on && isDeadBinder var -> char '_'
| not debug_on, CaseBind <- bind_site -> -- No parens, no kind info
pprUntypedBinder var
| dopt Opt_SuppressTypeSignatures dflags -> -- Suppress the signature
pprUntypedBinder var
| isTyVar var -> parens (pprKindedTyVarBndr var)
| otherwise ->
parens (hang (pprIdBndr var)
2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
where
unf_info = unfoldingInfo (idInfo var)
pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info
......@@ -298,9 +307,12 @@ pprTypedLamBinder bind_site debug_on var
pprTypedLetBinder :: Var -> SDoc
-- Print binder with a type or kind signature (not paren'd)
pprTypedLetBinder binder
| isTyVar binder = pprKindedTyVarBndr binder
| opt_SuppressTypeSignatures = pprIdBndr binder
| otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
= sdocWithDynFlags $ \dflags ->
case () of
_
| isTyVar binder -> pprKindedTyVarBndr binder
| dopt Opt_SuppressTypeSignatures dflags -> 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 *)
......@@ -314,9 +326,10 @@ pprIdBndr id = ppr id <+> pprIdBndrInfo (idInfo id)
pprIdBndrInfo :: IdInfo -> SDoc
pprIdBndrInfo info
| opt_SuppressIdInfo = empty
| otherwise
= megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
= sdocWithDynFlags $ \dflags ->
if dopt Opt_SuppressIdInfo dflags
then empty
else megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes
where
prag_info = inlinePragInfo info
occ_info = occInfo info
......@@ -344,9 +357,11 @@ pprIdBndrInfo info
\begin{code}
ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo id info
| opt_SuppressIdInfo = empty
| otherwise
= showAttributes
= sdocWithDynFlags $ \dflags ->
if dopt Opt_SuppressIdInfo dflags
then empty
else
showAttributes
[ (True, pp_scope <> ppr (idDetails id))
, (has_arity, ptext (sLit "Arity=") <> int arity)
, (has_caf_info, ptext (sLit "Caf=") <> ppr caf_info)
......
......@@ -125,7 +125,7 @@ module DynFlags (
import Platform
import Module
import PackageConfig
import PrelNames ( mAIN )
import {-# SOURCE #-} PrelNames ( mAIN )
import {-# SOURCE #-} Packages (PackageState)
import DriverPhases ( Phase(..), phaseInputExt )
import Config
......@@ -345,6 +345,23 @@ data DynFlag
-- instead of just the start position.
| Opt_PprCaseAsLet
-- Suppress all coercions, them replacing with '...'
| Opt_SuppressCoercions
| Opt_SuppressVarKinds
-- Suppress module id prefixes on variables.
| Opt_SuppressModulePrefixes
-- Suppress type applications.
| Opt_SuppressTypeApplications
-- Suppress info such as arity and unfoldings on identifiers.
| Opt_SuppressIdInfo
-- Suppress separate type signatures in core, but leave types on
-- lambda bound vars
| Opt_SuppressTypeSignatures
-- Suppress unique ids on variables.
-- Except for uniques, as some simplifier phases introduce new
-- variables that have otherwise identical names.
| Opt_SuppressUniques
-- temporary flags
| Opt_RunCPS
| Opt_RunCPSZ
......@@ -1914,6 +1931,15 @@ dynamic_flags = [
, Flag "dppr-user-length" (intSuffix (\n d -> d{ pprUserLength = n }))
, Flag "dppr-cols" (intSuffix (\n d -> d{ pprCols = n }))
, Flag "dtrace-level" (intSuffix (\n d -> d{ traceLevel = n }))
-- Suppress all that is suppressable in core dumps.
-- Except for uniques, as some simplifier phases introduce new varibles that
-- have otherwise identical names.
, Flag "dsuppress-all" (NoArg $ do setDynFlag Opt_SuppressCoercions
setDynFlag Opt_SuppressVarKinds
setDynFlag Opt_SuppressModulePrefixes
setDynFlag Opt_SuppressTypeApplications
setDynFlag Opt_SuppressIdInfo
setDynFlag Opt_SuppressTypeSignatures)
------ Debugging ----------------------------------------------------
, Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats))
......@@ -2229,7 +2255,14 @@ negatableFlags = [
-- | These @-d\<blah\>@ flags can all be reversed with @-dno-\<blah\>@
dFlags :: [FlagSpec DynFlag]
dFlags = [
( "ppr-case-as-let", Opt_PprCaseAsLet, nop ) ]
( "suppress-coercions", Opt_SuppressCoercions, nop),
( "suppress-var-kinds", Opt_SuppressVarKinds, nop),
( "suppress-module-prefixes", Opt_SuppressModulePrefixes, nop),
( "suppress-type-applications", Opt_SuppressTypeApplications, nop),
( "suppress-idinfo", Opt_SuppressIdInfo, nop),
( "suppress-type-signatures", Opt_SuppressTypeSignatures, nop),
( "suppress-uniques", Opt_SuppressUniques, nop),
( "ppr-case-as-let", Opt_PprCaseAsLet, nop)]
-- | These @-f\<blah\>@ flags can all be reversed with @-fno-\<blah\>@
fFlags :: [FlagSpec DynFlag]
......
......@@ -92,14 +92,6 @@ flagsStatic :: [Flag IO]
flagsStatic = [
------ Debugging ----------------------------------------------------
Flag "dppr-debug" (PassFlag addOpt)
, Flag "dsuppress-all" (PassFlag addOpt)
, Flag "dsuppress-uniques" (PassFlag addOpt)
, Flag "dsuppress-coercions" (PassFlag addOpt)
, Flag "dsuppress-module-prefixes" (PassFlag addOpt)
, Flag "dsuppress-type-applications" (PassFlag addOpt)
, Flag "dsuppress-idinfo" (PassFlag addOpt)
, Flag "dsuppress-var-kinds" (PassFlag addOpt)
, Flag "dsuppress-type-signatures" (PassFlag addOpt)
, Flag "dno-debug-output" (PassFlag addOpt)
-- rest of the debugging flags are dynamic
......
......@@ -29,16 +29,6 @@ module StaticFlags (
opt_PprStyle_Debug,
opt_NoDebugOutput,
-- Suppressing boring aspects of core dumps
opt_SuppressAll,
opt_SuppressUniques,
opt_SuppressCoercions,
opt_SuppressModulePrefixes,
opt_SuppressTypeApplications,
opt_SuppressIdInfo,
opt_SuppressTypeSignatures,
opt_SuppressVarKinds,
-- language opts
opt_DictsStrict,
......@@ -172,55 +162,6 @@ unpacked_opts =
-}
-- debugging options
-- | Suppress all that is suppressable in core dumps.
-- Except for uniques, as some simplifier phases introduce new varibles that
-- have otherwise identical names.
opt_SuppressAll :: Bool
opt_SuppressAll
= lookUp (fsLit "-dsuppress-all")
-- | Suppress all coercions, them replacing with '...'
opt_SuppressCoercions :: Bool
opt_SuppressCoercions
= lookUp (fsLit "-dsuppress-all")
|| lookUp (fsLit "-dsuppress-coercions")
opt_SuppressVarKinds :: Bool
opt_SuppressVarKinds
= lookUp (fsLit "-dsuppress-all")
|| lookUp (fsLit "-dsuppress-var-kinds")
-- | Suppress module id prefixes on variables.
opt_SuppressModulePrefixes :: Bool
opt_SuppressModulePrefixes
= lookUp (fsLit "-dsuppress-all")
|| lookUp (fsLit "-dsuppress-module-prefixes")
-- | Suppress type applications.
opt_SuppressTypeApplications :: Bool
opt_SuppressTypeApplications
= lookUp (fsLit "-dsuppress-all")
|| lookUp (fsLit "-dsuppress-type-applications")
-- | Suppress info such as arity and unfoldings on identifiers.
opt_SuppressIdInfo :: Bool
opt_SuppressIdInfo
= lookUp (fsLit "-dsuppress-all")
|| lookUp (fsLit "-dsuppress-idinfo")
-- | Suppress separate type signatures in core, but leave types on lambda bound vars
opt_SuppressTypeSignatures :: Bool
opt_SuppressTypeSignatures
= lookUp (fsLit "-dsuppress-all")
|| lookUp (fsLit "-dsuppress-type-signatures")
-- | Suppress unique ids on variables.
-- Except for uniques, as some simplifier phases introduce new variables that
-- have otherwise identical names.
opt_SuppressUniques :: Bool
opt_SuppressUniques
= lookUp (fsLit "-dsuppress-uniques")
opt_PprStyle_Debug :: Bool
opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug")
......
\begin{code}
module PrelNames where
import Module
mAIN :: Module
\end{code}
......@@ -2742,44 +2742,44 @@
</row>
<row>
<entry><option>-dsuppress-all</option></entry>
<entry>In core dumps, suppress everything that is suppressable.</entry>
<entry>static</entry>
<entry>In core dumps, suppress everything (except for uniques) that is suppressable.</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
<entry><option>-dsuppress-uniques</option></entry>
<entry>Suppress the printing of uniques in debug output (easier to use <command>diff</command>)</entry>
<entry>static</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
<entry><option>-dsuppress-idinfo</option></entry>
<entry>Suppress extended information about identifiers where they are bound</entry>
<entry>static</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
<entry><option>-dsuppress-module-prefixes</option></entry>
<entry>Suppress the printing of module qualification prefixes</entry>
<entry>static</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
<entry><option>-dsuppress-type-signatures</option></entry>
<entry>Suppress type signatures</entry>
<entry>static</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
<entry><option>-dsuppress-type-applications</option></entry>
<entry>Suppress type applications</entry>
<entry>static</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
<entry><option>-dsuppress-coercions</option></entry>
<entry>Suppress the printing of coercions in Core dumps to make them shorter</entry>
<entry>static</entry>
<entry>dynamic</entry>
<entry>-</entry>
</row>
<row>
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment