diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h
index 303d2bdc652b6a34e19196793f7c2ca7bdf1bfb9..16c0d64dbd7b79325498836e43a995e0a51b0df6 100644
--- a/compiler/HsVersions.h
+++ b/compiler/HsVersions.h
@@ -56,13 +56,13 @@ name = Util.globalMVar (value);
#ifdef DEBUG
#define ASSERT(e) if (not (e)) then (assertPanic __FILE__ __LINE__) else
#define ASSERT2(e,msg) if (not (e)) then (assertPprPanic __FILE__ __LINE__ (msg)) else
-#define WARN( e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $
+#define WARN( dflags, e, msg ) (warnPprTrace (e) __FILE__ __LINE__ (msg)) $
#else
-- We have to actually use all the variables we are given or we may get
-- unused variable warnings when DEBUG is off.
#define ASSERT(e) if False && (not (e)) then panic "ASSERT" else
#define ASSERT2(e,msg) if False && (const False (e,msg)) then pprPanic "ASSERT2" (msg) else
-#define WARN(e,msg) if False && (e) then pprPanic "WARN" (msg) else
+#define WARN(dflags,e,msg) if False && (e) then pprPanic (dflags) "WARN" (msg) else
-- Here we deliberately don't use when as Control.Monad might not be imported
#endif
diff --git a/compiler/basicTypes/Name.lhs b/compiler/basicTypes/Name.lhs
index f2ae963891b9f114302306c508e7201fdfdcd937..ca81fcca78e2f34d532ea6df51697c474ff2a0ee 100644
--- a/compiler/basicTypes/Name.lhs
+++ b/compiler/basicTypes/Name.lhs
@@ -72,6 +72,7 @@ module Name (
#include "Typeable.h"
import {-# SOURCE #-} TypeRep( TyThing )
+import {-# SOURCE #-} DynFlags (DynFlags)
import OccName
import Module
@@ -164,7 +165,7 @@ All built-in syntax is for wired-in things.
\begin{code}
nameUnique :: Name -> Unique
nameOccName :: Name -> OccName
-nameModule :: Name -> Module
+nameModule :: DynFlags -> Name -> Module
nameSrcLoc :: Name -> SrcLoc
nameSrcSpan :: Name -> SrcSpan
@@ -181,7 +182,7 @@ nameSrcSpan name = n_loc name
%************************************************************************
\begin{code}
-nameIsLocalOrFrom :: Module -> Name -> Bool
+nameIsLocalOrFrom :: DynFlags -> Module -> Name -> Bool
isInternalName :: Name -> Bool
isExternalName :: Name -> Bool
isSystemName :: Name -> Bool
@@ -204,14 +205,14 @@ isExternalName _ = False
isInternalName name = not (isExternalName name)
-nameModule name = nameModule_maybe name `orElse` pprPanic "nameModule" (ppr name)
+nameModule dflags name = nameModule_maybe name `orElse` pprPanic dflags "nameModule" (ppr name)
nameModule_maybe :: Name -> Maybe Module
nameModule_maybe (Name { n_sort = External mod}) = Just mod
nameModule_maybe (Name { n_sort = WiredIn mod _ _}) = Just mod
nameModule_maybe _ = Nothing
-nameIsLocalOrFrom from name
- | isExternalName name = from == nameModule name
+nameIsLocalOrFrom dflags from name
+ | isExternalName name = from == nameModule dflags name
| otherwise = True
isTyVarName :: Name -> Bool
@@ -220,8 +221,8 @@ isTyVarName name = isTvOcc (nameOccName name)
isTyConName :: Name -> Bool
isTyConName name = isTcOcc (nameOccName name)
-isDataConName :: Name -> Bool
-isDataConName name = isDataOcc (nameOccName name)
+isDataConName :: DynFlags -> Name -> Bool
+isDataConName dflags name = isDataOcc dflags (nameOccName name)
isValName :: Name -> Bool
isValName name = isValOcc (nameOccName name)
@@ -484,7 +485,9 @@ pprNameLoc name
| isGoodSrcSpan loc = pprDefnLoc loc
| isInternalName name || isSystemName name
= ptext (sLit "<no location info>")
- | otherwise = ptext (sLit "Defined in ") <> ppr (nameModule name)
+ | otherwise = sdocWithDynFlags $ \dflags ->
+ (ptext (sLit "Defined in ") <>
+ ppr (nameModule dflags name))
where loc = nameSrcSpan name
\end{code}
diff --git a/compiler/basicTypes/OccName.lhs b/compiler/basicTypes/OccName.lhs
index 5489ea7e2664337c4ac07cbda79007b81e76c55c..c86f9571ed7fd3f0bf41b1c5c28228a829f0a472 100644
--- a/compiler/basicTypes/OccName.lhs
+++ b/compiler/basicTypes/OccName.lhs
@@ -101,6 +101,7 @@ import UniqFM
import UniqSet
import FastString
import Outputable
+import {-# SOURCE #-} DynFlags (DynFlags)
import Binary
import StaticFlags( opt_SuppressUniques )
import Data.Char
@@ -427,7 +428,8 @@ occNameString (OccName _ s) = unpackFS s
setOccNameSpace :: NameSpace -> OccName -> OccName
setOccNameSpace sp (OccName _ occ) = OccName sp occ
-isVarOcc, isTvOcc, isTcOcc, isDataOcc :: OccName -> Bool
+isVarOcc, isTvOcc, isTcOcc :: OccName -> Bool
+isDataOcc :: DynFlags -> OccName -> Bool
isVarOcc (OccName VarName _) = True
isVarOcc _ = False
@@ -445,20 +447,20 @@ isValOcc (OccName VarName _) = True
isValOcc (OccName DataName _) = True
isValOcc _ = False
-isDataOcc (OccName DataName _) = True
-isDataOcc (OccName VarName s)
- | isLexCon s = pprPanic "isDataOcc: check me" (ppr s)
+isDataOcc _ (OccName DataName _) = True
+isDataOcc dflags (OccName VarName s)
+ | isLexCon s = pprPanic dflags "isDataOcc: check me" (ppr s)
-- Jan06: I don't think this should happen
-isDataOcc _ = False
+isDataOcc _ _ = False
-- | Test if the 'OccName' is a data constructor that starts with
-- a symbol (e.g. @:@, or @[]@)
-isDataSymOcc :: OccName -> Bool
-isDataSymOcc (OccName DataName s) = isLexConSym s
-isDataSymOcc (OccName VarName s)
- | isLexConSym s = pprPanic "isDataSymOcc: check me" (ppr s)
+isDataSymOcc :: DynFlags -> OccName -> Bool
+isDataSymOcc _ (OccName DataName s) = isLexConSym s
+isDataSymOcc dflags (OccName VarName s)
+ | isLexConSym s = pprPanic dflags "isDataSymOcc: check me" (ppr s)
-- Jan06: I don't think this should happen
-isDataSymOcc _ = False
+isDataSymOcc _ _ = False
-- Pretty inefficient!
-- | Test if the 'OccName' is that for any operator (whether
diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index c8a510f90ad0bb0396dc4c093c001c9903b38222..3c3b6b01cfc0a03590380db68805c87d9ed238da 100644
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -67,6 +67,7 @@ import SrcLoc
import FastString
import Outputable
import Util
+import {-# SOURCE #-} DynFlags (DynFlags)
import Data.Data
\end{code}
@@ -129,7 +130,7 @@ rdrNameOcc (Exact name) = nameOccName name
rdrNameSpace :: RdrName -> NameSpace
rdrNameSpace = occNameSpace . rdrNameOcc
-setRdrNameSpace :: RdrName -> NameSpace -> RdrName
+setRdrNameSpace :: DynFlags -> RdrName -> NameSpace -> RdrName
-- ^ This rather gruesome function is used mainly by the parser.
-- When parsing:
--
@@ -143,12 +144,12 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName
-- > data [] a = [] | a : [a]
--
-- For the exact-name case we return an original name.
-setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
-setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
-setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
-setRdrNameSpace (Exact n) ns = ASSERT( isExternalName n )
- Orig (nameModule n)
- (setOccNameSpace ns (nameOccName n))
+setRdrNameSpace _ (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
+setRdrNameSpace _ (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
+setRdrNameSpace _ (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
+setRdrNameSpace dflags (Exact n) ns = ASSERT( isExternalName n )
+ Orig (nameModule dflags n)
+ (setOccNameSpace ns (nameOccName n))
\end{code}
\begin{code}
@@ -185,9 +186,9 @@ nameRdrName name = Exact name
-- unique is still there for debug printing, particularly
-- of Types (which are converted to IfaceTypes before printing)
-nukeExact :: Name -> RdrName
-nukeExact n
- | isExternalName n = Orig (nameModule n) (nameOccName n)
+nukeExact :: DynFlags -> Name -> RdrName
+nukeExact dflags n
+ | isExternalName n = Orig (nameModule dflags n) (nameOccName n)
| otherwise = Unqual (nameOccName n)
\end{code}
@@ -504,17 +505,17 @@ mkGlobalRdrEnv gres
(nameOccName (gre_name gre))
gre
-findLocalDupsRdrEnv :: GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]])
+findLocalDupsRdrEnv :: DynFlags -> GlobalRdrEnv -> [OccName] -> (GlobalRdrEnv, [[Name]])
-- ^ For each 'OccName', see if there are multiple local definitions
-- for it. If so, remove all but one (to suppress subsequent error messages)
-- and return a list of the duplicate bindings
-findLocalDupsRdrEnv rdr_env occs
+findLocalDupsRdrEnv dflags rdr_env occs
= go rdr_env [] occs
where
go rdr_env dups [] = (rdr_env, dups)
go rdr_env dups (occ:occs)
= case filter isLocalGRE gres of
- [] -> WARN( True, ppr occ <+> ppr rdr_env )
+ [] -> WARN( dflags, True, ppr occ <+> ppr rdr_env )
go rdr_env dups occs -- Weird! No binding for occ
[_] -> go rdr_env dups occs -- The common case
dup_gres -> go (extendOccEnv rdr_env occ (head dup_gres : nonlocal_gres))
diff --git a/compiler/basicTypes/SrcLoc.lhs b/compiler/basicTypes/SrcLoc.lhs
index d2cbd7f07c2cb987ec17ae17d52d65e6def6c65e..bfeef0056b3b52b3bfe48f8792bd702e7ef0b594 100644
--- a/compiler/basicTypes/SrcLoc.lhs
+++ b/compiler/basicTypes/SrcLoc.lhs
@@ -74,6 +74,7 @@ module SrcLoc (
import Util
import Outputable
import FastString
+import {-# SOURCE #-} DynFlags (DynFlags)
import Data.Bits
import Data.Data
@@ -127,14 +128,14 @@ srcLocFile (SrcLoc fname _ _) = fname
srcLocFile _other = (fsLit "<unknown file")
-- | Raises an error when used on a "bad" 'SrcLoc'
-srcLocLine :: SrcLoc -> Int
-srcLocLine (SrcLoc _ l _) = l
-srcLocLine (UnhelpfulLoc s) = pprPanic "srcLocLine" (ftext s)
+srcLocLine :: DynFlags -> SrcLoc -> Int
+srcLocLine _ (SrcLoc _ l _) = l
+srcLocLine dflags (UnhelpfulLoc s) = pprPanic dflags "srcLocLine" (ftext s)
-- | Raises an error when used on a "bad" 'SrcLoc'
-srcLocCol :: SrcLoc -> Int
-srcLocCol (SrcLoc _ _ c) = c
-srcLocCol (UnhelpfulLoc s) = pprPanic "srcLocCol" (ftext s)
+srcLocCol :: DynFlags -> SrcLoc -> Int
+srcLocCol _ (SrcLoc _ _ c) = c
+srcLocCol dflags (UnhelpfulLoc s) = pprPanic dflags "srcLocCol" (ftext s)
-- | Move the 'SrcLoc' down by one line if the character is a newline,
-- to the next 8-char tabstop if it is a tab, and across by one
@@ -256,19 +257,19 @@ srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
-- | Create a 'SrcSpan' between two points in a file
-mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
-mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
-mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
-mkSrcSpan loc1 loc2
+mkSrcSpan :: DynFlags -> SrcLoc -> SrcLoc -> SrcSpan
+mkSrcSpan _ (UnhelpfulLoc str) _ = UnhelpfulSpan str
+mkSrcSpan _ _ (UnhelpfulLoc str) = UnhelpfulSpan str
+mkSrcSpan dflags loc1 loc2
| line1 == line2 = if col1 == col2
then SrcSpanPoint file line1 col1
else SrcSpanOneLine file line1 col1 col2
| otherwise = SrcSpanMultiLine file line1 col1 line2 col2
where
- line1 = srcLocLine loc1
- line2 = srcLocLine loc2
- col1 = srcLocCol loc1
- col2 = srcLocCol loc2
+ line1 = srcLocLine dflags loc1
+ line2 = srcLocLine dflags loc2
+ col1 = srcLocCol dflags loc1
+ col2 = srcLocCol dflags loc2
file = srcLocFile loc1
-- | Combines two 'SrcSpan' into one that spans at least all the characters
diff --git a/compiler/basicTypes/Var.lhs b/compiler/basicTypes/Var.lhs
index 3c3ff7f44055e84f020fac1ca3d93404760f3152..e06399580e83a66ad9dc458bbcbe44dfc313684b 100644
--- a/compiler/basicTypes/Var.lhs
+++ b/compiler/basicTypes/Var.lhs
@@ -76,6 +76,7 @@ import Util
import FastTypes
import FastString
import Outputable
+import DynFlags
import Data.Data
\end{code}
@@ -272,9 +273,9 @@ mkTcTyVar name kind details
tc_tv_details = details
}
-tcTyVarDetails :: TyVar -> TcTyVarDetails
-tcTyVarDetails (TcTyVar { tc_tv_details = details }) = details
-tcTyVarDetails var = pprPanic "tcTyVarDetails" (ppr var)
+tcTyVarDetails :: DynFlags -> TyVar -> TcTyVarDetails
+tcTyVarDetails _ (TcTyVar { tc_tv_details = details }) = details
+tcTyVarDetails dflags var = pprPanic dflags "tcTyVarDetails" (ppr var)
setTcTyVarDetails :: TyVar -> TcTyVarDetails -> TyVar
setTcTyVarDetails tv details = tv { tc_tv_details = details }
diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs
index 6988ae69055d723eb7fdea41a8e080acda849fee..acf06eb18173dfbb4e8394306309fdd1f16fdf3e 100644
--- a/compiler/cmm/CmmType.hs
+++ b/compiler/cmm/CmmType.hs
@@ -19,6 +19,7 @@ where
import Constants
import FastString
import Outputable
+import DynFlags
import Data.Word
import Data.Int
@@ -197,14 +198,14 @@ widthInBytes W64 = 8
widthInBytes W128 = 16
widthInBytes W80 = 10
-widthFromBytes :: Int -> Width
-widthFromBytes 1 = W8
-widthFromBytes 2 = W16
-widthFromBytes 4 = W32
-widthFromBytes 8 = W64
-widthFromBytes 16 = W128
-widthFromBytes 10 = W80
-widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n)
+widthFromBytes :: DynFlags -> Int -> Width
+widthFromBytes _ 1 = W8
+widthFromBytes _ 2 = W16
+widthFromBytes _ 4 = W32
+widthFromBytes _ 8 = W64
+widthFromBytes _ 16 = W128
+widthFromBytes _ 10 = W80
+widthFromBytes dflags n = pprPanic dflags "no width for given number of bytes" (ppr n)
-- log_2 of the width in bytes, useful for generating shifts.
widthInLog :: Width -> Int
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 18b0d8274a7259b61c859381bbcf58a374f684e3..3bc10edd80335174d26a7ee750fe84d066cccaf5 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -775,10 +775,10 @@ pprReg r = case r of
CmmLocal local -> pprLocalReg local
CmmGlobal global -> pprGlobalReg global
-pprAsPtrReg :: CmmReg -> SDoc
-pprAsPtrReg (CmmGlobal (VanillaReg n gcp))
- = WARN( gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p")
-pprAsPtrReg other_reg = pprReg other_reg
+pprAsPtrReg :: DynFlags -> CmmReg -> SDoc
+pprAsPtrReg dflags (CmmGlobal (VanillaReg n gcp))
+ = WARN( dflags, gcp /= VGcPtr, ppr n ) char 'R' <> int n <> ptext (sLit ".p")
+pprAsPtrReg _ other_reg = pprReg other_reg
pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg gr = case gr of
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index e04079d6669d461170372c04489e30eb8ff32f13..db1d809fb780b0732099d83a634f681d03077b36 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -211,7 +211,7 @@ mkStackLayout = do
[(offset - frame_sp - retAddrSizeW, b)
| (offset, b) <- binds]
- WARN( not (all (\bind -> fst bind >= 0) rel_binds),
+ WARN( dflags, not (all (\bind -> fst bind >= 0) rel_binds),
ppr binds $$ ppr rel_binds $$
ppr frame_size $$ ppr real_sp $$ ppr frame_sp )
return $ stack_layout rel_binds frame_size
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index d2c63b3be30a601fae3ba0511af093326ebbc924..3b6c5491bef667ba4d31802c1c4ae1113ba31dca 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -636,7 +636,7 @@ getCallMethod _ _ _ (LFUnknown True) _
getCallMethod _ name _ (LFUnknown False) n_args
| n_args > 0
- = WARN( True, ppr name <+> ppr n_args )
+ = WARN( dflags, True, ppr name <+> ppr n_args )
SlowCall -- Note [Unsafe coerce complications]
| otherwise
diff --git a/compiler/coreSyn/CoreArity.lhs b/compiler/coreSyn/CoreArity.lhs
index 0fa1c381e9efe45e2c42acfb407756faa9c3d8b3..fd0dec92cfc188cefac4dd4af9fe6e95649563f3 100644
--- a/compiler/coreSyn/CoreArity.lhs
+++ b/compiler/coreSyn/CoreArity.lhs
@@ -776,7 +776,7 @@ mkEtaWW orig_n orig_expr in_scope orig_ty
| otherwise -- We have an expression of arity > 0,
-- but its type isn't a function.
- = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
+ = WARN( dflags, True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
(getTvInScope subst, reverse eis)
-- This *can* legitmately happen:
-- e.g. coerce Int (\x. x) Essentially the programmer is
diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs
index 04057160b8f27d81e545c24e80c25a5d239d47ca..a318f20ebacaaa733466a0ac5e33031d27266aee 100644
--- a/compiler/coreSyn/CorePrep.lhs
+++ b/compiler/coreSyn/CorePrep.lhs
@@ -363,7 +363,7 @@ cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
; (floats3, rhs')
<- if manifestArity rhs1 <= arity
then return (floats2, cpeEtaExpand arity rhs2)
- else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
+ else WARN(dflags, True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
-- Note [Silly extra arguments]
(do { v <- newVar (idType bndr)
; let float = mkFloat False False v rhs2
diff --git a/compiler/coreSyn/CoreSubst.lhs b/compiler/coreSyn/CoreSubst.lhs
index 047e6c337b2553dbc187bbf14f0e27901af943bb..8ee3993cf39a88a490bfc1c8e31343fe21f09d89 100644
--- a/compiler/coreSyn/CoreSubst.lhs
+++ b/compiler/coreSyn/CoreSubst.lhs
@@ -251,7 +251,7 @@ lookupIdSubst doc (Subst in_scope ids _ _) v
| Just e <- lookupVarEnv ids v = e
| Just v' <- lookupInScope in_scope v = Var v'
-- Vital! See Note [Extending the Subst]
- | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope $$ doc)
+ | otherwise = WARN( dflags, True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope $$ doc)
Var v
-- | Find the substitution for a 'TyVar' in the 'Subst'
@@ -645,13 +645,13 @@ substUnfoldingSource (Subst in_scope ids _ _) (InlineWrapper wkr)
| Just wkr_expr <- lookupVarEnv ids wkr
= case wkr_expr of
Var w1 -> InlineWrapper w1
- _other -> -- WARN( True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr
+ _other -> -- WARN( dflags, True, text "Interesting! CoreSubst.substWorker1:" <+> ppr wkr
-- <+> ifPprDebug (equals <+> ppr wkr_expr) )
-- Note [Worker inlining]
InlineStable -- It's not a wrapper any more, but still inline it!
| Just w1 <- lookupInScope in_scope wkr = InlineWrapper w1
- | otherwise = -- WARN( True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
+ | otherwise = -- WARN( dflags, True, text "Interesting! CoreSubst.substWorker2:" <+> ppr wkr )
-- This can legitimately happen. The worker has been inlined and
-- dropped as dead code, because we don't treat the UnfoldingSource
-- as an "occurrence".
diff --git a/compiler/coreSyn/CoreSyn.lhs b/compiler/coreSyn/CoreSyn.lhs
index e754c6dda5d7e936a6aa3e4a8c5feb812eee8a87..79c0d7e092c59dfd6607f97cbc790ab2c55400a4 100644
--- a/compiler/coreSyn/CoreSyn.lhs
+++ b/compiler/coreSyn/CoreSyn.lhs
@@ -821,7 +821,7 @@ cmpAltCon (DataAlt _) DEFAULT = GT
cmpAltCon (LitAlt l1) (LitAlt l2) = l1 `compare` l2
cmpAltCon (LitAlt _) DEFAULT = GT
-cmpAltCon con1 con2 = WARN( True, text "Comparing incomparable AltCons" <+>
+cmpAltCon con1 con2 = WARN( dflags, True, text "Comparing incomparable AltCons" <+>
ppr con1 <+> ppr con2 )
LT
\end{code}
diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index 4146b621e158df90d53bcb01ad7346e0a3203726..580f4678912825ec5d1b5858cb3cda562c24e987 100644
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -210,7 +210,7 @@ mkCoerce co expr
-- if to_ty `eqType` from_ty
-- then expr
-- else
- WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
+ WARN(dflags, not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
(Cast expr co)
\end{code}
@@ -1223,10 +1223,10 @@ hash_expr env (Let (NonRec b r) e) = hash_expr (extend_env env b) e * fast_ha
hash_expr env (Let (Rec ((b,_):_)) e) = hash_expr (extend_env env b) e
hash_expr env (Case e _ _ _) = hash_expr env e
hash_expr env (Lam b e) = hash_expr (extend_env env b) e
-hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1
+hash_expr _ (Type _) = WARN(dflags, True, text "hash_expr: type") 1
-- Shouldn't happen. Better to use WARN than trace, because trace
-- prevents the CPR optimisation kicking in for hash_expr.
-hash_expr _ (Coercion _) = WARN(True, text "hash_expr: coercion") 1
+hash_expr _ (Coercion _) = WARN(dflags, True, text "hash_expr: coercion") 1
fast_hash_expr :: HashEnv -> CoreExpr -> Word32
fast_hash_expr env (Var v) = hashVar env v
diff --git a/compiler/main/Finder.lhs b/compiler/main/Finder.lhs
index 3ac3a473a3e1e5de26cea1ac327a0248f1b4eea2..f998e295ecccf1f03421d78bb237923cc4590275 100644
--- a/compiler/main/Finder.lhs
+++ b/compiler/main/Finder.lhs
@@ -635,7 +635,7 @@ cantFindErr cannot_find _ dflags mod_name find_result
from_exposed_pkg m = case lookupPackage pkg_map (modulePackageId m) of
Just pkg_config -> exposed pkg_config
- Nothing -> WARN( True, ppr m ) -- Should not happen
+ Nothing -> WARN( dflags, True, ppr m ) -- Should not happen
False
pp_exp mod = ppr (moduleName mod)
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs
index 17e2809202c5fd249145ec7e1743278e524bc8d1..2607c1047d3852415177afdc3e403e3d53941cba 100644
--- a/compiler/main/TidyPgm.lhs
+++ b/compiler/main/TidyPgm.lhs
@@ -678,7 +678,7 @@ chooseExternalIds hsc_env mod omit_prags expose_all binds implicit_binds imp_id_
-- unfolding in the *definition*; so look up in binder_set
refined_id = case lookupVarSet binder_set idocc of
Just id -> id
- Nothing -> WARN( True, ppr idocc ) idocc
+ Nothing -> WARN( dflags, True, ppr idocc ) idocc
unfold_env' = extendVarEnv unfold_env idocc (name',show_unfold)
referrer' | isExportedId refined_id = refined_id
@@ -1058,7 +1058,7 @@ tidyTopIdInfo rhs_tidy_env name orig_rhs tidy_rhs idinfo show_unfold caf_info
--------- Strictness ------------
final_sig | Just sig <- strictnessInfo idinfo
- = WARN( _bottom_hidden sig, ppr name ) Just sig
+ = WARN( dflags, _bottom_hidden sig, ppr name ) Just sig
| Just (_, sig) <- mb_bot_str = Just sig
| otherwise = Nothing
diff --git a/compiler/prelude/PrelRules.lhs b/compiler/prelude/PrelRules.lhs
index 93cc576a81dee4cb5026777d2c132e57f8ed2d64..82b9f690ee872822d4ec99911b155f870dc21b7c 100644
--- a/compiler/prelude/PrelRules.lhs
+++ b/compiler/prelude/PrelRules.lhs
@@ -508,7 +508,7 @@ tagToEnumRule _ [Type ty, Lit (MachInt i)]
(dc:rest) -> ASSERT( null rest )
Just (mkTyApps (Var (dataConWorkId dc)) tc_args)
| otherwise -- See Note [tagToEnum#]
- = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
+ = WARN( dflags, True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty )
Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type")
where
correct_tag dc = (dataConTag dc - fIRST_TAG) == tag
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index c3aef5d90fc1ca921e21e9692338292ef12d6719..24d9e7e8fe4511dfc489aad2ed521bde60607985 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -122,7 +122,7 @@ rnImportDecl this_mod implicit_prelude
-- Compiler sanity check: if the import didn't say
-- {-# SOURCE #-} we should not get a hi-boot file
- WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) (do
+ WARN( dflags, not want_boot && mi_boot iface, ppr imp_mod_name ) (do
-- Issue a user warning for a redundant {- SOURCE -} import
-- NB that we arrange to read all the ordinary imports before
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 76be4519d301d74f5611dc7ce895976b8ad6baa8..1ebedc9e9da98153ad8c31d4e8615317f1473a26 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -513,7 +513,7 @@ rnHsRecFields1 ctxt mk_arg (HsRecFields { rec_flds = flds, rec_dotdot = dotdot }
= do { env <- getGlobalRdrEnv
; return (case lookupGRE_Name env con of
[gre] -> gre_par gre
- gres -> WARN( True, ppr con <+> ppr gres ) NoParent) }
+ gres -> WARN( dflags, True, ppr con <+> ppr gres ) NoParent) }
| otherwise = return NoParent
dup_flds :: [[RdrName]]
diff --git a/compiler/simplCore/CSE.lhs b/compiler/simplCore/CSE.lhs
index 5bec8f0c3d7705dbaf78cce28f9886013004477d..0ab7b22a0c6bd09612ad1eb2040c6d06ffa85038 100644
--- a/compiler/simplCore/CSE.lhs
+++ b/compiler/simplCore/CSE.lhs
@@ -329,7 +329,7 @@ extendCSEnv (CS cs in_scope sub) expr expr'
where
hash = hashExpr expr
combine old new
- = WARN( result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
+ = WARN( dflags, result `lengthExceeds` 4, short_msg $$ nest 2 long_msg ) result
where
result = new ++ old
short_msg = ptext (sLit "extendCSEnv: long list, length") <+> int (length result)
@@ -348,7 +348,7 @@ addBinder :: CSEnv -> Id -> (CSEnv, Id)
addBinder (CS cs in_scope sub) v
| not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v)
| isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v')
- | otherwise = WARN( True, ppr v )
+ | otherwise = WARN( dflags, True, ppr v )
(CS emptyUFM in_scope sub, v)
-- This last case is the unusual situation where we have shadowing of
-- a type variable; we have to discard the CSE mapping
diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs
index 21dca615c3a1d230bfde2c8ff1b0c9e2534f94d6..bddbda20822717dc74558ee47b77332285a20a33 100644
--- a/compiler/simplCore/SetLevels.lhs
+++ b/compiler/simplCore/SetLevels.lhs
@@ -902,9 +902,10 @@ abstractVars dest_lvl (LE { le_lvl_env = lvl_env, le_env = id_env }) fvs
-- We are going to lambda-abstract, so nuke any IdInfo,
-- and add the tyvars of the Id (if necessary)
- zap v | isId v = WARN( isStableUnfolding (idUnfolding v) ||
- not (isEmptySpecInfo (idSpecialisation v)),
- text "absVarsOf: discarding info on" <+> ppr v )
+ zap v | isId v = WARN( dflags,
+ isStableUnfolding (idUnfolding v) ||
+ not (isEmptySpecInfo (idSpecialisation v)),
+ text "absVarsOf: discarding info on" <+> ppr v )
setIdInfo v vanillaIdInfo
| otherwise = v
diff --git a/compiler/simplCore/SimplCore.lhs b/compiler/simplCore/SimplCore.lhs
index b7466dc8b007b3f5ceb719e70ebf89983833c736..a6a066c0b599cf2d0e7a7e7c0242c0f0bb7b161e 100644
--- a/compiler/simplCore/SimplCore.lhs
+++ b/compiler/simplCore/SimplCore.lhs
@@ -339,7 +339,7 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode)
-- iteration_no is the number of the iteration we are
-- about to begin, with '1' for the first
| iteration_no > max_iterations -- Stop if we've run out of iterations
- = WARN( debugIsOn && (max_iterations > 2)
+ = WARN( dflags, debugIsOn && (max_iterations > 2)
, ptext (sLit "Simplifier baling out after") <+> int max_iterations
<+> ptext (sLit "iterations")
<+> (brackets $ hsep $ punctuate comma $
@@ -618,7 +618,7 @@ shortMeOut ind_env exported_id local_id
then
if hasShortableIdInfo exported_id
then True -- See Note [Messing up the exported Id's IdInfo]
- else WARN( True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
+ else WARN( dflags, True, ptext (sLit "Not shorting out:") <+> ppr exported_id )
False
else
False
diff --git a/compiler/simplCore/SimplEnv.lhs b/compiler/simplCore/SimplEnv.lhs
index 677a1e9d02cc60edd7a2f8a5d18e824099bd8e7c..358bcb1e1c02aa88f1f1ba223e2e79e2a94a189e 100644
--- a/compiler/simplCore/SimplEnv.lhs
+++ b/compiler/simplCore/SimplEnv.lhs
@@ -522,7 +522,7 @@ refine :: InScopeSet -> Var -> Var
refine in_scope v
| isLocalId v = case lookupInScope in_scope v of
Just v' -> v'
- Nothing -> WARN( True, ppr v ) v -- This is an error!
+ Nothing -> WARN( dflags, True, ppr v ) v -- This is an error!
| otherwise = v
lookupRecBndr :: SimplEnv -> InId -> OutId
diff --git a/compiler/simplCore/SimplUtils.lhs b/compiler/simplCore/SimplUtils.lhs
index 7d5d764fc6e3283ee1d5499d39483d2de0038e0c..c223ec45b2f94fd4aada2b6670d1942e4a4847ad 100644
--- a/compiler/simplCore/SimplUtils.lhs
+++ b/compiler/simplCore/SimplUtils.lhs
@@ -393,7 +393,7 @@ mkArgInfo fun rules n_val_args call_cont
else
map isStrictDmd demands ++ vanilla_stricts
| otherwise
- -> WARN( True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)
+ -> WARN( dflags, True, text "More demands than arity" <+> ppr fun <+> ppr (idArity fun)
<+> ppr n_val_args <+> ppr demands )
vanilla_stricts -- Not enough args, or no strictness
@@ -1110,7 +1110,7 @@ tryEtaExpand env bndr rhs
= do { dflags <- getDOptsSmpl
; (new_arity, new_rhs) <- try_expand dflags
- ; WARN( new_arity < old_arity || new_arity < _dmd_arity,
+ ; WARN( dflags, new_arity < old_arity || new_arity < _dmd_arity,
(ptext (sLit "Arity decrease:") <+> (ppr bndr <+> ppr old_arity
<+> ppr new_arity <+> ppr _dmd_arity) $$ ppr new_rhs) )
-- Note [Arity decrease]
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index b187897f890de47ba85b2ea78df75135b47b55a9..b7d9805f9631803c14ad1793067bcc1b8bf35675 100644
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -2012,7 +2012,7 @@ missingAlt :: SimplEnv -> Id -> [InAlt] -> SimplCont -> SimplM (SimplEnv, OutExp
-- it "sees" that the entire branch of an outer case is
-- inaccessible. So we simply put an error case here instead.
missingAlt env case_bndr alts cont
- = WARN( True, ptext (sLit "missingAlt") <+> ppr case_bndr )
+ = WARN( dflags, True, ptext (sLit "missingAlt") <+> ppr case_bndr )
return (env, mkImpossibleExpr res_ty)
where
res_ty = contResultType env (substTy env (coreAltsType alts)) cont
@@ -2176,7 +2176,7 @@ mkDupableAlt env case_bndr (con, bndrs', rhs')
rhs = mkConApp dc (map Type (tyConAppArgs scrut_ty)
++ varsToCoreExprs bndrs')
- LitAlt {} -> WARN( True, ptext (sLit "mkDupableAlt")
+ LitAlt {} -> WARN( dflags, True, ptext (sLit "mkDupableAlt")
<+> ppr case_bndr <+> ppr con )
case_bndr
-- The case binder is alive but trivial, so why has
diff --git a/compiler/specialise/SpecConstr.lhs b/compiler/specialise/SpecConstr.lhs
index 5fc022694171422401cb9a7aa6d0ce05538fb99e..b544f9bffd117baa5208f41f1615a3c4fa1046cf 100644
--- a/compiler/specialise/SpecConstr.lhs
+++ b/compiler/specialise/SpecConstr.lhs
@@ -1749,7 +1749,7 @@ samePat (vs1, as1) (vs2, as2)
same e1 (Note _ e2) = same e1 e2
same e1 (Cast e2 _) = same e1 e2
- same e1 e2 = WARN( bad e1 || bad e2, ppr e1 $$ ppr e2)
+ same e1 e2 = WARN( dflags, bad e1 || bad e2, ppr e1 $$ ppr e2)
False -- Let, lambda, case should not occur
bad (Case {}) = True
bad (Let {}) = True
diff --git a/compiler/specialise/Specialise.lhs b/compiler/specialise/Specialise.lhs
index c192b3f60afcc6c110a3032b24230876da77df68..57ad5e67f1e1e54b8c1df8a791ff8a7949679f39 100644
--- a/compiler/specialise/Specialise.lhs
+++ b/compiler/specialise/Specialise.lhs
@@ -649,7 +649,7 @@ specImport done rb fn calls_for_fn
; return (rules2 ++ rules1, spec_binds2 ++ spec_binds1) }
| otherwise
- = WARN( True, ptext (sLit "specImport discard") <+> ppr fn <+> ppr calls_for_fn )
+ = WARN( dflags, True, ptext (sLit "specImport discard") <+> ppr fn <+> ppr calls_for_fn )
return ([], [])
\end{code}
@@ -1024,7 +1024,7 @@ specCalls subst rules_for_me calls_for_me fn rhs
; return (spec_rules, spec_defns, plusUDList spec_uds) }
| otherwise -- No calls or RHS doesn't fit our preconceptions
- = WARN( notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for")
+ = WARN( dflags, notNull calls_for_me, ptext (sLit "Missed specialisation opportunity for")
<+> ppr fn $$ _trace_doc )
-- Note [Specialisation shape]
-- pprTrace "specDefn: none" (ppr fn $$ ppr calls_for_me) $
diff --git a/compiler/stgSyn/CoreToStg.lhs b/compiler/stgSyn/CoreToStg.lhs
index df8fabe7108a73065581e7a3f28213aa798a2e2e..2fb624647b5f61acb7809b65333385ff11bc7a95 100644
--- a/compiler/stgSyn/CoreToStg.lhs
+++ b/compiler/stgSyn/CoreToStg.lhs
@@ -218,7 +218,7 @@ coreTopBindToStg this_pkg env body_fvs (Rec pairs)
-- floated out a binding, in which case it will be approximate.
consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool
consistentCafInfo id bind
- = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
+ = WARN( dflags, not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy )
safe
where
safe = id_marked_caffy || not binding_is_caffy
@@ -608,7 +608,7 @@ coreToStgArgs (arg : args) = do -- Non-type argument
-- we complain.
-- We also want to check if a pointer is cast to a non-ptr etc
- WARN( bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
+ WARN( dflags, bad_args, ptext (sLit "Dangerous-looking argument. Probable cause: bad unsafeCoerce#") $$ ppr arg )
return (stg_arg : stg_args, fvs)
diff --git a/compiler/stranal/DmdAnal.lhs b/compiler/stranal/DmdAnal.lhs
index afa722fa8aa24142a4d6df0d5453b792a8cd8851..a643949a2a3b4aef75507871867a02d4885c63af 100644
--- a/compiler/stranal/DmdAnal.lhs
+++ b/compiler/stranal/DmdAnal.lhs
@@ -547,7 +547,7 @@ dmdAnalRhs top_lvl rec_flag env (id, rhs)
arity = idArity id -- The idArity should be up to date
-- The simplifier was run just beforehand
(rhs_dmd_ty, rhs') = dmdAnal env (vanillaCall arity) rhs
- (lazy_fv, sig_ty) = WARN( arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id )
+ (lazy_fv, sig_ty) = WARN( dflags, arity /= dmdTypeDepth rhs_dmd_ty && not (exprIsTrivial rhs), ppr id )
-- The RHS can be eta-reduced to just a variable,
-- in which case we should not complain.
mkSigTy top_lvl rec_flag id rhs rhs_dmd_ty
diff --git a/compiler/stranal/WorkWrap.lhs b/compiler/stranal/WorkWrap.lhs
index ac10b1b7737bd84347e76282d05e16b1df56fd63..e93a7399194a11a078797914a2474f2a020e2f2c 100644
--- a/compiler/stranal/WorkWrap.lhs
+++ b/compiler/stranal/WorkWrap.lhs
@@ -308,7 +308,7 @@ checkSize fn_id rhs thing_inside
splitFun :: Id -> IdInfo -> [Demand] -> DmdResult -> Expr Var
-> UniqSM [(Id, CoreExpr)]
splitFun fn_id fn_info wrap_dmds res_info rhs
- = WARN( not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
+ = WARN( dflags, not (wrap_dmds `lengthIs` arity), ppr fn_id <+> (ppr arity $$ ppr wrap_dmds $$ ppr res_info) )
(do {
-- The arity should match the signature
(work_demands, wrap_fn, work_fn) <- mkWwBodies fun_ty wrap_dmds res_info one_shots
diff --git a/compiler/stranal/WwLib.lhs b/compiler/stranal/WwLib.lhs
index 391c07c0894595954e1b9f42112cae71a68e9765..cd1b53b9dec16c0ed450d85cf7de7b301711222b 100644
--- a/compiler/stranal/WwLib.lhs
+++ b/compiler/stranal/WwLib.lhs
@@ -274,7 +274,7 @@ mkWWargs subst fun_ty arg_info
res_ty) }
| otherwise
- = WARN( True, ppr fun_ty ) -- Should not happen: if there is a demand
+ = WARN( dflags, True, ppr fun_ty ) -- Should not happen: if there is a demand
return ([], id, id, substTy subst fun_ty) -- then there should be a function arrow
applyToVars :: [Var] -> CoreExpr -> CoreExpr
@@ -424,7 +424,7 @@ mkWWcpr :: Type -- function body type
mkWWcpr body_ty RetCPR
| not (isClosedAlgType body_ty)
- = WARN( True,
+ = WARN( dflags, True,
text "mkWWcpr: non-algebraic or open body type" <+> ppr body_ty )
return (id, id, body_ty)
@@ -521,7 +521,7 @@ mk_absent_let arg
| arg_ty `eqType` realWorldStatePrimTy
= Just (Let (NonRec arg (Var realWorldPrimId)))
| otherwise
- = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty )
+ = WARN( dflags, True, ptext (sLit "No absent value for") <+> ppr arg_ty )
Nothing
where
arg_ty = idType arg
diff --git a/compiler/typecheck/TcErrors.lhs b/compiler/typecheck/TcErrors.lhs
index b199053ac2e5bbebe6452a0298035b51919ce651..28ec43a42ec4802f96a318ba3ebc950094a499fc 100644
--- a/compiler/typecheck/TcErrors.lhs
+++ b/compiler/typecheck/TcErrors.lhs
@@ -737,7 +737,7 @@ monomorphism_fix dflags
getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo
getSkolemInfo [] tv
- = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv )
+ = WARN( dflags, True, ptext (sLit "No skolem info:") <+> ppr tv )
UnkSkol
getSkolemInfo (implic:implics) tv
| tv `elemVarSet` ic_skols implic = ctLocOrigin (ic_loc implic)
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 12b50acff09067c846c23444ae734d3058815c06..1c6dc9d6259f08edc907a7ee46e7751794c1d2b1 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -528,7 +528,7 @@ zonkExpr env (HsBracketOut body bs)
zonk_b (n,e) = zonkLExpr env e `thenM` \ e' ->
returnM (n,e')
-zonkExpr _ (HsSpliceE s) = WARN( True, ppr s ) -- Should not happen
+zonkExpr _ (HsSpliceE s) = WARN( dflags, True, ppr s ) -- Should not happen
returnM (HsSpliceE s)
zonkExpr env (OpApp e1 op fixity e2)
diff --git a/compiler/typecheck/TcMType.lhs b/compiler/typecheck/TcMType.lhs
index 2c01d2300a4505c34164414c5f746b6d8f862d7c..8384fd04d1163fe21ce5bdaa4d16d0b3bb96596b 100644
--- a/compiler/typecheck/TcMType.lhs
+++ b/compiler/typecheck/TcMType.lhs
@@ -325,14 +325,14 @@ writeMetaTyVar tyvar ty
-- Everything from here on only happens if DEBUG is on
| not (isTcTyVar tyvar)
- = WARN( True, text "Writing to non-tc tyvar" <+> ppr tyvar )
+ = WARN( dflags, True, text "Writing to non-tc tyvar" <+> ppr tyvar )
return ()
| MetaTv _ ref <- tcTyVarDetails tyvar
= writeMetaTyVarRef tyvar ref ty
| otherwise
- = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar )
+ = WARN( dflags, True, text "Writing to non-meta tyvar" <+> ppr tyvar )
return ()
--------------------
@@ -347,7 +347,7 @@ writeMetaTyVarRef tyvar ref ty
-- Everything from here on only happens if DEBUG is on
| not (isPredTy tv_kind) -- Don't check kinds for updates to coercion variables
, not (ty_kind `isSubKind` tv_kind)
- = WARN( True, hang (text "Ill-kinded update to meta tyvar")
+ = WARN( dflags, True, hang (text "Ill-kinded update to meta tyvar")
2 (ppr tyvar $$ ppr tv_kind $$ ppr ty $$ ppr ty_kind) )
return ()
@@ -543,7 +543,7 @@ zonkQuantifiedTyVar :: TcTyVar -> TcM TcTyVar
zonkQuantifiedTyVar tv
= ASSERT2( isTcTyVar tv, ppr tv )
case tcTyVarDetails tv of
- SkolemTv {} -> WARN( True, ppr tv ) -- Dec10: Can this really happen?
+ SkolemTv {} -> WARN( dflags, True, ppr tv ) -- Dec10: Can this really happen?
do { kind <- zonkTcType (tyVarKind tv)
; return $ setTyVarKind tv kind }
-- It might be a skolem type variable,
@@ -556,7 +556,7 @@ zonkQuantifiedTyVar tv
(readMutVar _ref >>= \cts ->
case cts of
Flexi -> return ()
- Indirect ty -> WARN( True, ppr tv $$ ppr ty )
+ Indirect ty -> WARN( dflags, True, ppr tv $$ ppr ty )
return ()) >>
#endif
skolemiseUnboundMetaTyVar tv vanillaSkolemTv
diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs
index 17e5dcbb949400e9a82f9be412668b16ef1e6c47..7733e1e2ab22e102d1a91244cbdda213cd65c02f 100644
--- a/compiler/typecheck/TcRnTypes.lhs
+++ b/compiler/typecheck/TcRnTypes.lhs
@@ -650,7 +650,7 @@ plusImportAvails
imp_finsts = finsts1 `unionLists` finsts2 }
where
plus_mod_dep (m1, boot1) (m2, boot2)
- = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
+ = WARN( dflags, not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
-- Check mod-names match
(m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that
\end{code}
@@ -1077,7 +1077,7 @@ pprSkolInfo (InferSkol ids) = sep [ ptext (sLit "the inferred type of")
-- UnkSkol
-- For type variables the others are dealt with by pprSkolTvBinding.
-- For Insts, these cases should not happen
-pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol")
+pprSkolInfo UnkSkol = WARN( dflags, True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol")
\end{code}
diff --git a/compiler/types/Coercion.lhs b/compiler/types/Coercion.lhs
index 7df5b8e38fb82d77f1689165bdc8a70631827695..9fc3c6e89ef1573154f847279945426057c2bd17 100644
--- a/compiler/types/Coercion.lhs
+++ b/compiler/types/Coercion.lhs
@@ -870,7 +870,7 @@ substCoVar :: CvSubst -> CoVar -> Coercion
substCoVar (CvSubst in_scope _ cenv) cv
| Just co <- lookupVarEnv cenv cv = co
| Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1
- | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv )
+ | otherwise = WARN( dflags, True, ptext (sLit "substCoVar not in scope") <+> ppr cv )
ASSERT( isCoVar cv ) CoVarCo cv
substCoVars :: CvSubst -> [CoVar] -> [Coercion]
diff --git a/compiler/types/OptCoercion.lhs b/compiler/types/OptCoercion.lhs
index eef1ccf6722aadf685b035bfd89e2baafc4733a6..aa5af1dd726fb92faf0f20e7cb9fc199f07fd6d4 100644
--- a/compiler/types/OptCoercion.lhs
+++ b/compiler/types/OptCoercion.lhs
@@ -70,9 +70,10 @@ opt_co env sym co
= pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $
co1 `seq`
pprTrace "opt_co done }" (ppr co1) $
- (WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (Pair s1 t1)
+ (WARN( dflags,
+ not same_co_kind, ppr co <+> dcolon <+> pprEqPred (Pair s1 t1)
$$ ppr co1 <+> dcolon <+> pprEqPred (Pair s2 t2) )
- WARN( not (coreEqCoercion co1 simple_result),
+ WARN( dflags, not (coreEqCoercion co1 simple_result),
(text "env=" <+> ppr env) $$
(text "input=" <+> ppr co) $$
(text "simple=" <+> ppr simple_result) $$
@@ -106,7 +107,7 @@ opt_co' env sym (CoVarCo cv)
= ASSERT( isCoVar cv1 ) wrapSym sym (CoVarCo cv1)
-- cv1 might have a substituted kind!
- | otherwise = WARN( True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env)
+ | otherwise = WARN( dflags, True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env)
ASSERT( isCoVar cv )
wrapSym sym (CoVarCo cv)
diff --git a/compiler/utils/GraphOps.hs b/compiler/utils/GraphOps.hs
index 1fa4199aa22c9b2ac99ca9cda8c1b68adb2761f5..55c22ade2a781b7a95a4bd275839950529abec6c 100644
--- a/compiler/utils/GraphOps.hs
+++ b/compiler/utils/GraphOps.hs
@@ -21,6 +21,7 @@ where
import GraphBase
+import DynFlags
import Outputable
import Unique
import UniqSet
@@ -510,12 +511,13 @@ scanGraph match graph
--
validateGraph
:: (Uniquable k, Outputable k, Eq color)
- => SDoc -- ^ extra debugging info to display on error
+ => DynFlags
+ -> SDoc -- ^ extra debugging info to display on error
-> Bool -- ^ whether this graph is supposed to be colored.
-> Graph k cls color -- ^ graph to validate
-> Graph k cls color -- ^ validated graph
-validateGraph doc isColored graph
+validateGraph dflags doc isColored graph
-- Check that all edges point to valid nodes.
| edges <- unionManyUniqSets
@@ -525,7 +527,7 @@ validateGraph doc isColored graph
, nodes <- mkUniqSet $ map nodeId $ eltsUFM $ graphMap graph
, badEdges <- minusUniqSet edges nodes
, not $ isEmptyUniqSet badEdges
- = pprPanic "GraphOps.validateGraph"
+ = pprPanic dflags "GraphOps.validateGraph"
( text "Graph has edges that point to non-existant nodes"
$$ text " bad edges: " <> vcat (map ppr $ uniqSetToList badEdges)
$$ doc )
diff --git a/compiler/utils/ListSetOps.lhs b/compiler/utils/ListSetOps.lhs
index 83334fbb289def38b2d6c77675d97fb1d1d36a08..5cc53488da6da6a2dd3cf975f4ec3d49f43ba7cd 100644
--- a/compiler/utils/ListSetOps.lhs
+++ b/compiler/utils/ListSetOps.lhs
@@ -25,6 +25,7 @@ import Outputable
import Unique
import UniqFM
import Util
+import DynFlags
import Data.List
\end{code}
@@ -43,10 +44,10 @@ insertList :: Eq a => a -> [a] -> [a]
insertList x xs | isIn "insert" x xs = xs
| otherwise = x : xs
-unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a]
+unionLists :: (Outputable a, Eq a) => DynFlags -> [a] -> [a] -> [a]
-- Assumes that the arguments contain no duplicates
-unionLists xs ys
- = WARN(length xs > 100 || length ys > 100, ppr xs $$ ppr ys)
+unionLists dflags xs ys
+ = WARN(dflags, length xs > 100 || length ys > 100, ppr xs $$ ppr ys)
[x | x <- xs, isn'tIn "unionLists" x ys] ++ ys
minusList :: (Eq a) => [a] -> [a] -> [a]
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 3fd0915a220094362e87a93fe0f76094d80bab4b..12540dbc395d405d87f2a0db496b98b9810a5c16 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -16,6 +16,7 @@ module Outputable (
-- * Pretty printing combinators
SDoc, runSDoc, initSDocContext,
+ sdocWithDynFlags,
docToSDoc,
interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr,
empty, nest,
@@ -246,6 +247,11 @@ initSDocContext' dflags sty = SDC
, sdocDynFlags = dflags
}
+sdocWithDynFlags :: (DynFlags -> SDoc) -> SDoc
+sdocWithDynFlags f = SDoc (\sdc -> case f (sdocDynFlags sdc) of
+ SDoc mkDoc ->
+ mkDoc sdc)
+
withPprStyle :: PprStyle -> SDoc -> SDoc
withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty}
@@ -873,9 +879,9 @@ plural _ = char 's'
\begin{code}
-pprPanic :: String -> SDoc -> a
+pprPanic :: DynFlags -> String -> SDoc -> a
-- ^ Throw an exception saying "bug in GHC"
-pprPanic = pprAndThen panic
+pprPanic _ = pprAndThen panic
pprSorry :: String -> SDoc -> a
-- ^ Throw an exceptio saying "this isn't finished yet"