More DynFlags + SDocsdoc

41 files changed, 142 insertions, 122 deletions

diff --git a/compiler/HsVersions.h b/compiler/HsVersions.h
index 303d2bdc65..16c0d64dbd 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 f2ae963891..ca81fcca78 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 5489ea7e26..c86f9571ed 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 c8a510f90a..3c3b6b01cf 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 d2cbd7f07c..bfeef0056b 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 3c3ff7f440..e06399580e 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 6988ae6905..acf06eb181 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 18b0d8274a..3bc10edd80 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 e04079d666..db1d809fb7 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 d2c63b3be3..3b6c5491be 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 0fa1c381e9..fd0dec92cf 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 04057160b8..a318f20eba 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 047e6c337b..8ee3993cf3 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 e754c6dda5..79c0d7e092 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 4146b621e1..580f467891 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 3ac3a473a3..f998e295ec 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 17e2809202..2607c1047d 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 93cc576a81..82b9f690ee 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 c3aef5d90f..24d9e7e8fe 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 76be4519d3..1ebedc9e9d 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 5bec8f0c3d..0ab7b22a0c 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 21dca615c3..bddbda2082 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 b7466dc8b0..a6a066c0b5 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 677a1e9d02..358bcb1e1c 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 7d5d764fc6..c223ec45b2 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 b187897f89..b7d9805f96 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 5fc0226941..b544f9bffd 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 c192b3f60a..57ad5e67f1 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 df8fabe710..2fb624647b 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 afa722fa8a..a643949a2a 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 ac10b1b773..e93a739919 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 391c07c089..cd1b53b9de 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 b199053ac2..28ec43a42e 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 12b50acff0..1c6dc9d625 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 2c01d2300a..8384fd04d1 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 17e5dcbb94..7733e1e2ab 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 7df5b8e38f..9fc3c6e89e 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 eef1ccf672..aa5af1dd72 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 1fa4199aa2..55c22ade2a 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 83334fbb28..5cc53488da 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 3fd0915a22..12540dbc39 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"