Make the -dsuppress-* flags dynamic

compiler/basicTypes/Name.lhs

@@ -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)

compiler/basicTypes/OccName.lhs

@@ -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 = []

compiler/basicTypes/Var.lhs

@@ -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
 

compiler/coreSyn/PprCore.lhs

@@ -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)

compiler/main/DynFlags.hs

@@ -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]

compiler/main/StaticFlagParser.hs

@@ -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
 

compiler/main/StaticFlags.hs

@@ -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")

compiler/prelude/PrelNames.lhs-boot

+
+\begin{code}
+module PrelNames where
+
+import Module
+
+mAIN :: Module
+\end{code}
+

docs/users_guide/flags.xml

@@ -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>