More DynFlags + SDocsdoc

6 files changed, 13 insertions, 12 deletions

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