Commit bbd3c399 authored by Sylvain Henry's avatar Sylvain Henry Committed by Ben Gamari

Ditch static flags

This patch converts the 4 lasting static flags (read from the command
line and unsafely stored in immutable global variables) into dynamic
flags. Most use cases have been converted into reading them from a DynFlags.

In cases for which we don't have easy access to a DynFlags, we read from
'unsafeGlobalDynFlags' that is set at the beginning of each 'runGhc'.
It's not perfect (not thread-safe) but it is still better as we can
set/unset these 4 flags before each run when using GHC API.

Updates haddock submodule.

Rebased and finished by: bgamari

Test Plan: validate

Reviewers: goldfire, erikd, hvr, austin, simonmar, bgamari

Reviewed By: simonmar

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2839

GHC Trac Issues: #8440
parent 6128b2ff
...@@ -508,9 +508,9 @@ mkBackpackMsg = do ...@@ -508,9 +508,9 @@ mkBackpackMsg = do
-- | 'PprStyle' for Backpack messages; here we usually want the module to -- | 'PprStyle' for Backpack messages; here we usually want the module to
-- be qualified (so we can tell how it was instantiated.) But we try not -- be qualified (so we can tell how it was instantiated.) But we try not
-- to qualify packages so we can use simple names for them. -- to qualify packages so we can use simple names for them.
backpackStyle :: PprStyle backpackStyle :: DynFlags -> PprStyle
backpackStyle = backpackStyle dflags =
mkUserStyle mkUserStyle dflags
(QueryQualify neverQualifyNames (QueryQualify neverQualifyNames
alwaysQualifyModules alwaysQualifyModules
neverQualifyPackages) AllTheWay neverQualifyPackages) AllTheWay
...@@ -529,7 +529,8 @@ msgUnitId pk = do ...@@ -529,7 +529,8 @@ msgUnitId pk = do
dflags <- getDynFlags dflags <- getDynFlags
level <- getBkpLevel level <- getBkpLevel
liftIO . backpackProgressMsg level dflags liftIO . backpackProgressMsg level dflags
$ "Instantiating " ++ renderWithStyle dflags (ppr pk) backpackStyle $ "Instantiating " ++ renderWithStyle dflags (ppr pk)
(backpackStyle dflags)
-- | Message when we include a Backpack unit. -- | Message when we include a Backpack unit.
msgInclude :: (Int,Int) -> UnitId -> BkpM () msgInclude :: (Int,Int) -> UnitId -> BkpM ()
...@@ -538,7 +539,7 @@ msgInclude (i,n) uid = do ...@@ -538,7 +539,7 @@ msgInclude (i,n) uid = do
level <- getBkpLevel level <- getBkpLevel
liftIO . backpackProgressMsg level dflags liftIO . backpackProgressMsg level dflags
$ showModuleIndex (i, n) ++ "Including " ++ $ showModuleIndex (i, n) ++ "Including " ++
renderWithStyle dflags (ppr uid) backpackStyle renderWithStyle dflags (ppr uid) (backpackStyle dflags)
-- ---------------------------------------------------------------------------- -- ----------------------------------------------------------------------------
-- Conversion from PackageName to HsComponentId -- Conversion from PackageName to HsComponentId
......
...@@ -109,7 +109,6 @@ module BasicTypes( ...@@ -109,7 +109,6 @@ module BasicTypes(
import FastString import FastString
import Outputable import Outputable
import SrcLoc ( Located,unLoc ) import SrcLoc ( Located,unLoc )
import StaticFlags( opt_PprStyle_Debug )
import Data.Data hiding (Fixity, Prefix, Infix) import Data.Data hiding (Fixity, Prefix, Infix)
import Data.Function (on) import Data.Function (on)
...@@ -739,8 +738,9 @@ tupleParens :: TupleSort -> SDoc -> SDoc ...@@ -739,8 +738,9 @@ tupleParens :: TupleSort -> SDoc -> SDoc
tupleParens BoxedTuple p = parens p tupleParens BoxedTuple p = parens p
tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)") tupleParens UnboxedTuple p = text "(#" <+> p <+> ptext (sLit "#)")
tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %) tupleParens ConstraintTuple p -- In debug-style write (% Eq a, Ord b %)
| opt_PprStyle_Debug = text "(%" <+> p <+> ptext (sLit "%)") = sdocWithPprDebug $ \dbg -> if dbg
| otherwise = parens p then text "(%" <+> p <+> ptext (sLit "%)")
else parens p
{- {-
************************************************************************ ************************************************************************
......
...@@ -116,6 +116,7 @@ module Id ( ...@@ -116,6 +116,7 @@ module Id (
#include "HsVersions.h" #include "HsVersions.h"
import DynFlags
import CoreSyn ( CoreRule, evaldUnfolding, Unfolding( NoUnfolding ) ) import CoreSyn ( CoreRule, evaldUnfolding, Unfolding( NoUnfolding ) )
import IdInfo import IdInfo
...@@ -147,7 +148,6 @@ import Unique ...@@ -147,7 +148,6 @@ import Unique
import UniqSupply import UniqSupply
import FastString import FastString
import Util import Util
import StaticFlags
-- infixl so you can say (id `set` a `set` b) -- infixl so you can say (id `set` a `set` b)
infixl 1 `setIdUnfolding`, infixl 1 `setIdUnfolding`,
...@@ -771,7 +771,7 @@ typeOneShot ty ...@@ -771,7 +771,7 @@ typeOneShot ty
isStateHackType :: Type -> Bool isStateHackType :: Type -> Bool
isStateHackType ty isStateHackType ty
| opt_NoStateHack | hasNoStateHack unsafeGlobalDynFlags
= False = False
| otherwise | otherwise
= case tyConAppTyCon_maybe ty of = case tyConAppTyCon_maybe ty of
......
...@@ -77,7 +77,6 @@ import Outputable ...@@ -77,7 +77,6 @@ import Outputable
import Unique import Unique
import UniqFM import UniqFM
import Util import Util
import StaticFlags( opt_PprStyle_Debug )
import NameEnv import NameEnv
import Data.Data import Data.Data
...@@ -1191,8 +1190,9 @@ pprNameProvenance :: GlobalRdrElt -> SDoc ...@@ -1191,8 +1190,9 @@ pprNameProvenance :: GlobalRdrElt -> SDoc
-- ^ Print out one place where the name was define/imported -- ^ Print out one place where the name was define/imported
-- (With -dppr-debug, print them all) -- (With -dppr-debug, print them all)
pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss }) pprNameProvenance (GRE { gre_name = name, gre_lcl = lcl, gre_imp = iss })
| opt_PprStyle_Debug = vcat pp_provs = sdocWithPprDebug $ \dbg -> if dbg
| otherwise = head pp_provs then vcat pp_provs
else head pp_provs
where where
pp_provs = pp_lcl ++ map pp_is iss pp_provs = pp_lcl ++ map pp_is iss
pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)] pp_lcl = if lcl then [text "defined at" <+> ppr (nameSrcLoc name)]
......
...@@ -82,7 +82,6 @@ import Unique ...@@ -82,7 +82,6 @@ import Unique
import Util import Util
import Maybes import Maybes
import Outputable import Outputable
import StaticFlags
{- {-
************************************************************************ ************************************************************************
...@@ -180,13 +179,14 @@ uniqAway' (InScope set n) var ...@@ -180,13 +179,14 @@ uniqAway' (InScope set n) var
orig_unique = getUnique var orig_unique = getUnique var
try k try k
| debugIsOn && (k > 1000) | debugIsOn && (k > 1000)
= pprPanic "uniqAway loop:" (ppr k <+> text "tries" <+> ppr var <+> int n) = pprPanic "uniqAway loop:" msg
| uniq `elemVarSetByKey` set = try (k + 1) | uniq `elemVarSetByKey` set = try (k + 1)
| debugIsOn && opt_PprStyle_Debug && (k > 3) | k > 3
= pprTrace "uniqAway:" (ppr k <+> text "tries" <+> ppr var <+> int n) = pprTraceDebug "uniqAway:" msg
setVarUnique var uniq setVarUnique var uniq
| otherwise = setVarUnique var uniq | otherwise = setVarUnique var uniq
where where
msg = ppr k <+> text "tries" <+> ppr var <+> int n
uniq = deriveUnique orig_unique (n * k) uniq = deriveUnique orig_unique (n * k)
{- {-
......
...@@ -239,7 +239,6 @@ import Unique ...@@ -239,7 +239,6 @@ import Unique
import UniqFM import UniqFM
import SrcLoc import SrcLoc
import DynFlags import DynFlags
import StaticFlags
import ErrUtils import ErrUtils
import StringBuffer import StringBuffer
import FastString import FastString
......
...@@ -50,7 +50,6 @@ import TyCon ...@@ -50,7 +50,6 @@ import TyCon
import CoAxiom import CoAxiom
import BasicTypes import BasicTypes
import ErrUtils as Err import ErrUtils as Err
import StaticFlags
import ListSetOps import ListSetOps
import PrelNames import PrelNames
import Outputable import Outputable
...@@ -305,7 +304,8 @@ displayLintResults :: DynFlags -> CoreToDo ...@@ -305,7 +304,8 @@ displayLintResults :: DynFlags -> CoreToDo
-> IO () -> IO ()
displayLintResults dflags pass warns errs binds displayLintResults dflags pass warns errs binds
| not (isEmptyBag errs) | not (isEmptyBag errs)
= do { log_action dflags dflags NoReason Err.SevDump noSrcSpan defaultDumpStyle = do { log_action dflags dflags NoReason Err.SevDump noSrcSpan
(defaultDumpStyle dflags)
(vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs (vcat [ lint_banner "errors" (ppr pass), Err.pprMessageBag errs
, text "*** Offending Program ***" , text "*** Offending Program ***"
, pprCoreBindings binds , pprCoreBindings binds
...@@ -313,9 +313,10 @@ displayLintResults dflags pass warns errs binds ...@@ -313,9 +313,10 @@ displayLintResults dflags pass warns errs binds
; Err.ghcExit dflags 1 } ; Err.ghcExit dflags 1 }
| not (isEmptyBag warns) | not (isEmptyBag warns)
, not opt_NoDebugOutput , not (hasNoDebugOutput dflags)
, showLintWarnings pass , showLintWarnings pass
= log_action dflags dflags NoReason Err.SevDump noSrcSpan defaultDumpStyle = log_action dflags dflags NoReason Err.SevDump noSrcSpan
(defaultDumpStyle dflags)
(lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns) (lint_banner "warnings" (ppr pass) $$ Err.pprMessageBag warns)
| otherwise = return () | otherwise = return ()
...@@ -346,7 +347,7 @@ lintInteractiveExpr what hsc_env expr ...@@ -346,7 +347,7 @@ lintInteractiveExpr what hsc_env expr
display_lint_err err display_lint_err err
= do { log_action dflags dflags NoReason Err.SevDump = do { log_action dflags dflags NoReason Err.SevDump
noSrcSpan defaultDumpStyle noSrcSpan (defaultDumpStyle dflags)
(vcat [ lint_banner "errors" (text what) (vcat [ lint_banner "errors" (text what)
, err , err
, text "*** Offending Program ***" , text "*** Offending Program ***"
...@@ -1933,9 +1934,10 @@ addMsg env msgs msg ...@@ -1933,9 +1934,10 @@ addMsg env msgs msg
locs = le_loc env locs = le_loc env
(loc, cxt1) = dumpLoc (head locs) (loc, cxt1) = dumpLoc (head locs)
cxts = [snd (dumpLoc loc) | loc <- locs] cxts = [snd (dumpLoc loc) | loc <- locs]
context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 $$ context = sdocWithPprDebug $ \dbg -> if dbg
text "Substitution:" <+> ppr (le_subst env) then vcat (reverse cxts) $$ cxt1 $$
| otherwise = cxt1 text "Substitution:" <+> ppr (le_subst env)
else cxt1
mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg) mk_msg msg = mkLocMessage SevWarning (mkSrcSpan loc loc) (context $$ msg)
...@@ -2383,7 +2385,7 @@ lintAnnots pname pass guts = do ...@@ -2383,7 +2385,7 @@ lintAnnots pname pass guts = do
when (not (null diffs)) $ CoreMonad.putMsg $ vcat when (not (null diffs)) $ CoreMonad.putMsg $ vcat
[ lint_banner "warning" pname [ lint_banner "warning" pname
, text "Core changes with annotations:" , text "Core changes with annotations:"
, withPprStyle defaultDumpStyle $ nest 2 $ vcat diffs , withPprStyle (defaultDumpStyle dflags) $ nest 2 $ vcat diffs
] ]
-- Return actual new guts -- Return actual new guts
return nguts return nguts
......
...@@ -111,8 +111,8 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds ...@@ -111,8 +111,8 @@ addTicksToBinds hsc_env mod mod_loc exports tyCons binds
modBreaks <- mkModBreaks hsc_env mod tickCount entries modBreaks <- mkModBreaks hsc_env mod tickCount entries
when (dopt Opt_D_dump_ticked dflags) $ when (dopt Opt_D_dump_ticked dflags) $
log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle log_action dflags dflags NoReason SevDump noSrcSpan
(pprLHsBinds binds1) (defaultDumpStyle dflags) (pprLHsBinds binds1)
return (binds1, HpcInfo tickCount hashNo, Just modBreaks) return (binds1, HpcInfo tickCount hashNo, Just modBreaks)
......
...@@ -353,7 +353,6 @@ Library ...@@ -353,7 +353,6 @@ Library
Plugins Plugins
TcPluginM TcPluginM
PprTyThing PprTyThing
StaticFlags
StaticPtrTable StaticPtrTable
SysTools SysTools
SysTools.Terminal SysTools.Terminal
......
...@@ -531,7 +531,6 @@ compiler_stage2_dll0_MODULES = \ ...@@ -531,7 +531,6 @@ compiler_stage2_dll0_MODULES = \
RdrName \ RdrName \
Rules \ Rules \
SrcLoc \ SrcLoc \
StaticFlags \
StringBuffer \ StringBuffer \
SysTools.Terminal \ SysTools.Terminal \
TcEvidence \ TcEvidence \
......
...@@ -243,7 +243,8 @@ withExtendedLinkEnv new_env action ...@@ -243,7 +243,8 @@ withExtendedLinkEnv new_env action
showLinkerState :: DynFlags -> IO () showLinkerState :: DynFlags -> IO ()
showLinkerState dflags showLinkerState dflags
= do pls <- readIORef v_PersistentLinkerState >>= readMVar = do pls <- readIORef v_PersistentLinkerState >>= readMVar
log_action dflags dflags NoReason SevDump noSrcSpan defaultDumpStyle log_action dflags dflags NoReason SevDump noSrcSpan
(defaultDumpStyle dflags)
(vcat [text "----- Linker state -----", (vcat [text "----- Linker state -----",
text "Pkgs:" <+> ppr (pkgs_loaded pls), text "Pkgs:" <+> ppr (pkgs_loaded pls),
text "Objs:" <+> ppr (objs_loaded pls), text "Objs:" <+> ppr (objs_loaded pls),
...@@ -382,7 +383,8 @@ classifyLdInput dflags f ...@@ -382,7 +383,8 @@ classifyLdInput dflags f
| isObjectFilename platform f = return (Just (Object f)) | isObjectFilename platform f = return (Just (Object f))
| isDynLibFilename platform f = return (Just (DLLPath f)) | isDynLibFilename platform f = return (Just (DLLPath f))
| otherwise = do | otherwise = do
log_action dflags dflags NoReason SevInfo noSrcSpan defaultUserStyle log_action dflags dflags NoReason SevInfo noSrcSpan
(defaultUserStyle dflags)
(text ("Warning: ignoring unrecognised input `" ++ f ++ "'")) (text ("Warning: ignoring unrecognised input `" ++ f ++ "'"))
return Nothing return Nothing
where platform = targetPlatform dflags where platform = targetPlatform dflags
...@@ -1450,7 +1452,7 @@ maybePutStr dflags s ...@@ -1450,7 +1452,7 @@ maybePutStr dflags s
NoReason NoReason
SevInteractive SevInteractive
noSrcSpan noSrcSpan
defaultUserStyle (defaultUserStyle dflags)
(text s) (text s)
maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn :: DynFlags -> String -> IO ()
......
...@@ -59,7 +59,6 @@ import GHC.Arr ( Array(..) ) ...@@ -59,7 +59,6 @@ import GHC.Arr ( Array(..) )
import GHC.Exts import GHC.Exts
import GHC.IO ( IO(..) ) import GHC.IO ( IO(..) )
import StaticFlags( opt_PprStyle_Debug )
import Control.Monad import Control.Monad
import Data.Maybe import Data.Maybe
import Data.Array.Base import Data.Array.Base
...@@ -340,22 +339,22 @@ ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do ...@@ -340,22 +339,22 @@ ppr_termM y p Term{dc=Left dc_tag, subTerms=tt} = do
return $ cparen (not (null tt) && p >= app_prec) return $ cparen (not (null tt) && p >= app_prec)
(text dc_tag <+> pprDeeperList fsep tt_docs) (text dc_tag <+> pprDeeperList fsep tt_docs)
ppr_termM y p Term{dc=Right dc, subTerms=tt} ppr_termM y p Term{dc=Right dc, subTerms=tt} = do
{- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity {- | dataConIsInfix dc, (t1:t2:tt') <- tt --TODO fixity
= parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2)
<+> hsep (map (ppr_term1 True) tt) <+> hsep (map (ppr_term1 True) tt)
-} -- TODO Printing infix constructors properly -} -- TODO Printing infix constructors properly
| null sub_terms_to_show tt_docs' <- mapM (y app_prec) tt
= return (ppr dc) return $ sdocWithPprDebug $ \dbg ->
| otherwise -- Don't show the dictionary arguments to
= do { tt_docs <- mapM (y app_prec) sub_terms_to_show -- constructors unless -dppr-debug is on
; return $ cparen (p >= app_prec) $ let tt_docs = if dbg
sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] } then tt_docs'
where else dropList (dataConTheta dc) tt_docs'
sub_terms_to_show -- Don't show the dictionary arguments to in if null tt_docs
-- constructors unless -dppr-debug is on then ppr dc
| opt_PprStyle_Debug = tt else cparen (p >= app_prec) $
| otherwise = dropList (dataConTheta dc) tt sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)]
ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
ppr_termM y p RefWrap{wrapped_term=t} = do ppr_termM y p RefWrap{wrapped_term=t} = do
......
...@@ -38,7 +38,6 @@ import BasicTypes ...@@ -38,7 +38,6 @@ import BasicTypes
import ConLike import ConLike
import SrcLoc import SrcLoc
import Util import Util
import StaticFlags( opt_PprStyle_Debug )
import Outputable import Outputable
import FastString import FastString
import Type import Type
...@@ -2465,12 +2464,14 @@ pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctx ...@@ -2465,12 +2464,14 @@ pprStmtContext (PatGuard ctxt) = text "pattern guard for" $$ pprMatchContext ctx
-- in a transformed branch of -- in a transformed branch of
-- transformed branch of -- transformed branch of
-- transformed branch of monad comprehension -- transformed branch of monad comprehension
pprStmtContext (ParStmtCtxt c) pprStmtContext (ParStmtCtxt c) =
| opt_PprStyle_Debug = sep [text "parallel branch of", pprAStmtContext c] sdocWithPprDebug $ \dbg -> if dbg
| otherwise = pprStmtContext c then sep [text "parallel branch of", pprAStmtContext c]
pprStmtContext (TransStmtCtxt c) else pprStmtContext c
| opt_PprStyle_Debug = sep [text "transformed branch of", pprAStmtContext c] pprStmtContext (TransStmtCtxt c) =
| otherwise = pprStmtContext c sdocWithPprDebug $ \dbg -> if dbg
then sep [text "transformed branch of", pprAStmtContext c]
else pprStmtContext c
instance (Outputable id, Outputable (NameOrRdrName id)) instance (Outputable id, Outputable (NameOrRdrName id))
=> Outputable (HsStmtContext id) where => Outputable (HsStmtContext id) where
......
...@@ -84,7 +84,6 @@ import Type ...@@ -84,7 +84,6 @@ import Type
import HsDoc import HsDoc
import BasicTypes import BasicTypes
import SrcLoc import SrcLoc
import StaticFlags
import Outputable import Outputable
import FastString import FastString
import Maybes( isJust ) import Maybes( isJust )
...@@ -1192,11 +1191,8 @@ pprHsForAllExtra extra qtvs cxt ...@@ -1192,11 +1191,8 @@ pprHsForAllExtra extra qtvs cxt
show_extra = isJust extra show_extra = isJust extra
pprHsForAllTvs :: (OutputableBndrId name) => [LHsTyVarBndr name] -> SDoc pprHsForAllTvs :: (OutputableBndrId name) => [LHsTyVarBndr name] -> SDoc
pprHsForAllTvs qtvs pprHsForAllTvs qtvs = sdocWithPprDebug $ \debug ->
| show_forall = forAllLit <+> interppSP qtvs <> dot ppWhen (debug || not (null qtvs)) $ forAllLit <+> interppSP qtvs <> dot
| otherwise = empty
where
show_forall = opt_PprStyle_Debug || not (null qtvs)
pprHsContext :: (OutputableBndrId name) => HsContext name -> SDoc pprHsContext :: (OutputableBndrId name) => HsContext name -> SDoc
pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe pprHsContext = maybe empty (<+> darrow) . pprHsContextMaybe
......
...@@ -81,7 +81,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do ...@@ -81,7 +81,7 @@ readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path ncu = do
NoReason NoReason
SevOutput SevOutput
noSrcSpan noSrcSpan
defaultDumpStyle (defaultDumpStyle dflags)
sd sd
QuietBinIFaceReading -> \_ -> return () QuietBinIFaceReading -> \_ -> return ()
wantedGot :: Outputable a => String -> a -> a -> IO () wantedGot :: Outputable a => String -> a -> a -> IO ()
......
...@@ -64,7 +64,6 @@ import Binary ...@@ -64,7 +64,6 @@ import Binary
import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue ) import BooleanFormula ( BooleanFormula, pprBooleanFormula, isTrue )
import Var( TyVarBndr(..) ) import Var( TyVarBndr(..) )
import TyCon ( Role (..), Injectivity(..), HowAbstract(..) ) import TyCon ( Role (..), Injectivity(..), HowAbstract(..) )
import StaticFlags (opt_PprStyle_Debug)
import Util( filterOut, filterByList ) import Util( filterOut, filterByList )
import DataCon (SrcStrictness(..), SrcUnpackedness(..)) import DataCon (SrcStrictness(..), SrcUnpackedness(..))
import Lexeme (isLexSym) import Lexeme (isLexSym)
...@@ -980,7 +979,7 @@ pprIfaceConDecl ss gadt_style fls tycon tc_binders parent ...@@ -980,7 +979,7 @@ pprIfaceConDecl ss gadt_style fls tycon tc_binders parent
| otherwise | otherwise
= sep [pp_field_args, arrow <+> pp_res_ty] = sep [pp_field_args, arrow <+> pp_res_ty]
ppr_bang IfNoBang = ppWhen opt_PprStyle_Debug $ char '_' ppr_bang IfNoBang = sdocWithPprDebug $ \dbg -> ppWhen dbg $ char '_'
ppr_bang IfStrict = char '!' ppr_bang IfStrict = char '!'
ppr_bang IfUnpack = text "{-# UNPACK #-}" ppr_bang IfUnpack = text "{-# UNPACK #-}"
ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <> ppr_bang (IfUnpackCo co) = text "! {-# UNPACK #-}" <>
......
...@@ -7,6 +7,7 @@ This module defines interface types and binders ...@@ -7,6 +7,7 @@ This module defines interface types and binders
-} -}
{-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-} {-# LANGUAGE CPP, FlexibleInstances, BangPatterns #-}
{-# LANGUAGE MultiWayIf #-}
-- FlexibleInstances for Binary (DefMethSpec IfaceType) -- FlexibleInstances for Binary (DefMethSpec IfaceType)
module IfaceType ( module IfaceType (
...@@ -52,7 +53,6 @@ module IfaceType ( ...@@ -52,7 +53,6 @@ module IfaceType (
import {-# SOURCE #-} TysWiredIn ( liftedRepDataConTyCon ) import {-# SOURCE #-} TysWiredIn ( liftedRepDataConTyCon )
import DynFlags import DynFlags
import StaticFlags ( opt_PprStyle_Debug )
import TyCon hiding ( pprPromotionQuote ) import TyCon hiding ( pprPromotionQuote )
import CoAxiom import CoAxiom
import Var import Var
...@@ -972,15 +972,17 @@ pprTyTcApp' ctxt_prec tc tys dflags style ...@@ -972,15 +972,17 @@ pprTyTcApp' ctxt_prec tc tys dflags style
, rep `ifaceTyConHasKey` liftedRepDataConKey , rep `ifaceTyConHasKey` liftedRepDataConKey
= kindStar = kindStar
| not opt_PprStyle_Debug | otherwise
, tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey = sdocWithPprDebug $ \dbg ->
= text "(TypeError ...)" -- Suppress detail unles you _really_ want to see if | not dbg && tc `ifaceTyConHasKey` errorMessageTypeErrorFamKey
-- Suppress detail unles you _really_ want to see
-> text "(TypeError ...)"
| Just doc <- ppr_equality tc (tcArgsIfaceTypes tys) | Just doc <- ppr_equality tc (tcArgsIfaceTypes tys)
= doc -> doc
| otherwise | otherwise
= ppr_iface_tc_app ppr_ty