Pass DynFlags down to mk_err_msg

13 files changed, 116 insertions, 103 deletions

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 64b2ae410a..9d831b7fc2 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -1070,7 +1070,7 @@ parseCmmFile dflags filename = do
 		-- in there we don't want.
   case unP cmmParse init_state of
     PFailed span err -> do
-        let msg = mkPlainErrMsg span err
+        let msg = mkPlainErrMsg dflags span err
         return ((emptyBag, unitBag msg), Nothing)
     POk pst code -> do
         cmm <- initC dflags no_module (getCmm (unEC code initEnv [] >> return ()))
diff --git a/compiler/deSugar/DsMonad.lhs b/compiler/deSugar/DsMonad.lhs
index a781615ec0..46c7bf269b 100644
--- a/compiler/deSugar/DsMonad.lhs
+++ b/compiler/deSugar/DsMonad.lhs
@@ -361,14 +361,16 @@ putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc})
 warnDs :: SDoc -> DsM ()
 warnDs warn = do { env <- getGblEnv 
                  ; loc <- getSrcSpanDs
-                 ; let msg = mkWarnMsg loc (ds_unqual env)  warn
+                 ; dflags <- getDynFlags
+                 ; let msg = mkWarnMsg dflags loc (ds_unqual env)  warn
                  ; updMutVar (ds_msgs env) (\ (w,e) -> (w `snocBag` msg, e)) }
 
 failWithDs :: SDoc -> DsM a
 failWithDs err 
   = do  { env <- getGblEnv 
         ; loc <- getSrcSpanDs
-        ; let msg = mkErrMsg loc (ds_unqual env) err
+        ; dflags <- getDynFlags
+        ; let msg = mkErrMsg dflags loc (ds_unqual env) err
         ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg))
         ; failM }
 
diff --git a/compiler/iface/MkIface.lhs b/compiler/iface/MkIface.lhs
index 0ccab30ae5..dd87cc74fa 100644
--- a/compiler/iface/MkIface.lhs
+++ b/compiler/iface/MkIface.lhs
@@ -322,10 +322,10 @@ mkIface_ hsc_env maybe_old_fingerprint
                 | otherwise                     = emptyBag
               errs_and_warns = (orph_warnings, emptyBag)
               unqual = mkPrintUnqualified dflags rdr_env
-              inst_warns = listToBag [ instOrphWarn unqual d 
+              inst_warns = listToBag [ instOrphWarn dflags unqual d 
                                      | (d,i) <- insts `zip` iface_insts
                                      , isNothing (ifInstOrph i) ]
-              rule_warns = listToBag [ ruleOrphWarn unqual this_mod r 
+              rule_warns = listToBag [ ruleOrphWarn dflags unqual this_mod r 
                                      | r <- iface_rules
                                      , isNothing (ifRuleOrph r)
                                      , if ifRuleAuto r then warn_auto_orphs
@@ -849,14 +849,14 @@ oldMD5 dflags bh = do
         return $! readHexFingerprint hash_str
 -}
 
-instOrphWarn :: PrintUnqualified -> ClsInst -> WarnMsg
-instOrphWarn unqual inst
-  = mkWarnMsg (getSrcSpan inst) unqual $
+instOrphWarn :: DynFlags -> PrintUnqualified -> ClsInst -> WarnMsg
+instOrphWarn dflags unqual inst
+  = mkWarnMsg dflags (getSrcSpan inst) unqual $
     hang (ptext (sLit "Orphan instance:")) 2 (pprInstanceHdr inst)
 
-ruleOrphWarn :: PrintUnqualified -> Module -> IfaceRule -> WarnMsg
-ruleOrphWarn unqual mod rule
-  = mkWarnMsg silly_loc unqual $
+ruleOrphWarn :: DynFlags -> PrintUnqualified -> Module -> IfaceRule -> WarnMsg
+ruleOrphWarn dflags unqual mod rule
+  = mkWarnMsg dflags silly_loc unqual $
     ptext (sLit "Orphan rule:") <+> ppr rule
   where
     silly_loc = srcLocSpan (mkSrcLoc (moduleNameFS (moduleName mod)) 1 1)
diff --git a/compiler/main/DriverMkDepend.hs b/compiler/main/DriverMkDepend.hs
index 1694aba9b8..5db927a952 100644
--- a/compiler/main/DriverMkDepend.hs
+++ b/compiler/main/DriverMkDepend.hs
@@ -240,8 +240,10 @@ findDependency hsc_env srcloc pkg imp is_boot include_pkg_deps
                 | otherwise
                 -> return Nothing
 
-            fail -> throwOneError $ mkPlainErrMsg srcloc $
-                        cannotFindModule (hsc_dflags hsc_env) imp fail
+            fail ->
+                let dflags = hsc_dflags hsc_env
+                in throwOneError $ mkPlainErrMsg dflags srcloc $
+                        cannotFindModule dflags imp fail
         }
 
 -----------------------------
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index 87092c1d89..201a38cdb4 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -774,7 +774,7 @@ runPhase (Cpp sf) input_fn dflags0
        (dflags1, unhandled_flags, warns)
            <- io $ parseDynamicFilePragma dflags0 src_opts
        setDynFlags dflags1
-       io $ checkProcessArgsResult unhandled_flags
+       io $ checkProcessArgsResult dflags1 unhandled_flags
 
        if not (xopt Opt_Cpp dflags1) then do
            -- we have to be careful to emit warnings only once.
@@ -791,7 +791,7 @@ runPhase (Cpp sf) input_fn dflags0
             src_opts <- io $ getOptionsFromFile dflags0 output_fn
             (dflags2, unhandled_flags, warns)
                 <- io $ parseDynamicFilePragma dflags0 src_opts
-            io $ checkProcessArgsResult unhandled_flags
+            io $ checkProcessArgsResult dflags2 unhandled_flags
             unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns
             -- the HsPp pass below will emit warnings
 
@@ -826,7 +826,7 @@ runPhase (HsPp sf) input_fn dflags
             (dflags1, unhandled_flags, warns)
                 <- io $ parseDynamicFilePragma dflags src_opts
             setDynFlags dflags1
-            io $ checkProcessArgsResult unhandled_flags
+            io $ checkProcessArgsResult dflags1 unhandled_flags
             io $ handleFlagWarnings dflags1 warns
 
             return (Hsc sf, output_fn)
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index c97ab2aef2..dafc7e61aa 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -107,32 +107,33 @@ makeIntoWarning err = err { errMsgSeverity = SevWarning }
 -- -----------------------------------------------------------------------------
 -- Collecting up messages for later ordering and printing.
 
-mk_err_msg :: Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
-mk_err_msg sev locn print_unqual msg extra 
+mk_err_msg :: DynFlags -> Severity -> SrcSpan -> PrintUnqualified -> MsgDoc -> SDoc -> ErrMsg
+mk_err_msg _ sev locn print_unqual msg extra 
  = ErrMsg { errMsgSpans = [locn], errMsgContext = print_unqual
           , errMsgShortDoc = msg, errMsgExtraInfo = extra
           , errMsgSeverity = sev }
 
-mkLongErrMsg, mkLongWarnMsg   :: SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
+mkLongErrMsg, mkLongWarnMsg   :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc -> MsgDoc -> ErrMsg
 -- A long (multi-line) error message
-mkErrMsg, mkWarnMsg           :: SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg
+mkErrMsg, mkWarnMsg           :: DynFlags -> SrcSpan -> PrintUnqualified -> MsgDoc            -> ErrMsg
 -- A short (one-line) error message
-mkPlainErrMsg, mkPlainWarnMsg :: SrcSpan ->                     MsgDoc            -> ErrMsg
+mkPlainErrMsg, mkPlainWarnMsg :: DynFlags -> SrcSpan ->                     MsgDoc            -> ErrMsg
 -- Variant that doesn't care about qualified/unqualified names
 
-mkLongErrMsg   locn unqual msg extra = mk_err_msg SevError   locn unqual        msg extra
-mkErrMsg       locn unqual msg       = mk_err_msg SevError   locn unqual        msg empty
-mkPlainErrMsg  locn        msg       = mk_err_msg SevError   locn alwaysQualify msg empty
-mkLongWarnMsg  locn unqual msg extra = mk_err_msg SevWarning locn unqual        msg extra
-mkWarnMsg      locn unqual msg       = mk_err_msg SevWarning locn unqual        msg empty
-mkPlainWarnMsg locn        msg       = mk_err_msg SevWarning locn alwaysQualify msg empty
+mkLongErrMsg   dflags locn unqual msg extra = mk_err_msg dflags SevError   locn unqual        msg extra
+mkErrMsg       dflags locn unqual msg       = mk_err_msg dflags SevError   locn unqual        msg empty
+mkPlainErrMsg  dflags locn        msg       = mk_err_msg dflags SevError   locn alwaysQualify msg empty
+mkLongWarnMsg  dflags locn unqual msg extra = mk_err_msg dflags SevWarning locn unqual        msg extra
+mkWarnMsg      dflags locn unqual msg       = mk_err_msg dflags SevWarning locn unqual        msg empty
+mkPlainWarnMsg dflags locn        msg       = mk_err_msg dflags SevWarning locn alwaysQualify msg empty
 
 ----------------
 emptyMessages :: Messages
 emptyMessages = (emptyBag, emptyBag)
 
-warnIsErrorMsg :: ErrMsg
-warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.")
+warnIsErrorMsg :: DynFlags -> ErrMsg
+warnIsErrorMsg dflags
+    = mkPlainErrMsg dflags noSrcSpan (text "\nFailing due to -Werror.")
 
 errorsFound :: DynFlags -> Messages -> Bool
 errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 5f9eb7c428..27f6f96d8a 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -1198,7 +1198,9 @@ getTokenStream mod = do
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts  -> return ts
-    PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
+    PFailed span err ->
+        do dflags <- getDynFlags
+           throw $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
 
 -- | Give even more information on the source than 'getTokenStream'
 -- This function allows reconstructing the source completely with
@@ -1209,7 +1211,9 @@ getRichTokenStream mod = do
   let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
   case lexTokenStream source startLoc flags of
     POk _ ts -> return $ addSourceToTokens startLoc source ts
-    PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err)
+    PFailed span err ->
+        do dflags <- getDynFlags
+           throw $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
 
 -- | Given a source location and a StringBuffer corresponding to this
 -- location, return a rich token stream with the source associated to the
@@ -1381,7 +1385,7 @@ parser str dflags filename =
    case unP Parser.parseModule (mkPState dflags buf loc) of
 
      PFailed span err   -> 
-         Left (unitBag (mkPlainErrMsg span err))
+         Left (unitBag (mkPlainErrMsg dflags span err))
 
      POk pst rdr_module ->
          let (warns,_) = getMessages pst in
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 9fb4287837..322c631a4c 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -1021,15 +1021,16 @@ nodeMapElts = Map.elems
 -- were necessary, then the edge would be part of a cycle.
 warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m ()
 warnUnnecessarySourceImports sccs = do
-  logWarnings (listToBag (concatMap (check.flattenSCC) sccs))
-  where check ms =
+  dflags <- getDynFlags
+  logWarnings (listToBag (concatMap (check dflags . flattenSCC) sccs))
+  where check dflags ms =
            let mods_in_this_cycle = map ms_mod_name ms in
-           [ warn i | m <- ms, i <- ms_home_srcimps m,
-                      unLoc i `notElem`  mods_in_this_cycle ]
+           [ warn dflags i | m <- ms, i <- ms_home_srcimps m,
+                             unLoc i `notElem`  mods_in_this_cycle ]
 
-        warn :: Located ModuleName -> WarnMsg
-        warn (L loc mod) = 
-           mkPlainErrMsg loc
+        warn :: DynFlags -> Located ModuleName -> WarnMsg
+        warn dflags (L loc mod) =
+           mkPlainErrMsg dflags loc
                 (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ")
                  <+> quotes (ppr mod))
 
@@ -1067,6 +1068,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
        summs <- loop (concatMap msDeps rootSummaries) root_map
        return summs
      where
+        dflags = hsc_dflags hsc_env
         roots = hsc_targets hsc_env
 
         old_summary_map :: NodeMap ModSummary
@@ -1078,14 +1080,14 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
                 if exists 
                     then summariseFile hsc_env old_summaries file mb_phase 
                                        obj_allowed maybe_buf
-                    else throwOneError $ mkPlainErrMsg noSrcSpan $
+                    else throwOneError $ mkPlainErrMsg dflags noSrcSpan $
                            text "can't find file:" <+> text file
         getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf)
            = do maybe_summary <- summariseModule hsc_env old_summary_map False 
                                            (L rootLoc modl) obj_allowed 
                                            maybe_buf excl_mods
                 case maybe_summary of
-                   Nothing -> packageModErr modl
+                   Nothing -> packageModErr dflags modl
                    Just s  -> return s
 
         rootLoc = mkGeneralSrcSpan (fsLit "<command line>")
@@ -1098,7 +1100,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
         checkDuplicates root_map 
            | allow_dup_roots = return ()
            | null dup_roots  = return ()
-           | otherwise       = liftIO $ multiRootsErr (head dup_roots)
+           | otherwise       = liftIO $ multiRootsErr dflags (head dup_roots)
            where
              dup_roots :: [[ModSummary]]        -- Each at least of length 2
              dup_roots = filterOut isSingleton (nodeMapElts root_map)
@@ -1118,7 +1120,7 @@ downsweep hsc_env old_summaries excl_mods allow_dup_roots
           = if isSingleton summs then
                 loop ss done
             else
-                do { multiRootsErr summs; return [] }
+                do { multiRootsErr dflags summs; return [] }
           | otherwise
           = do mb_s <- summariseModule hsc_env old_summary_map 
                                        is_boot wanted_mod True
@@ -1342,7 +1344,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
                 -- It might have been deleted since the Finder last found it
         maybe_t <- modificationTimeIfExists src_fn
         case maybe_t of
-          Nothing -> noHsFileErr loc src_fn
+          Nothing -> noHsFileErr dflags loc src_fn
           Just t  -> new_summary location' mod src_fn t
 
 
@@ -1354,7 +1356,7 @@ summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod)
         (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn
 
         when (mod_name /= wanted_mod) $
-                throwOneError $ mkPlainErrMsg mod_loc $ 
+                throwOneError $ mkPlainErrMsg dflags' mod_loc $
                               text "File name does not match module name:" 
                               $$ text "Saw:" <+> quotes (ppr mod_name)
                               $$ text "Expected:" <+> quotes (ppr wanted_mod)
@@ -1402,7 +1404,7 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
 
         (dflags', leftovers, warns)
             <- parseDynamicFilePragma dflags local_opts
-        checkProcessArgsResult leftovers
+        checkProcessArgsResult dflags leftovers
         handleFlagWarnings dflags' warns
 
         let needs_preprocessing
@@ -1426,21 +1428,21 @@ preprocessFile hsc_env src_fn mb_phase (Just (buf, _time))
 noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab
 -- ToDo: we don't have a proper line number for this error
 noModError dflags loc wanted_mod err
-  = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err
+  = throwOneError $ mkPlainErrMsg dflags loc $ cannotFindModule dflags wanted_mod err
                                 
-noHsFileErr :: SrcSpan -> String -> IO a
-noHsFileErr loc path
-  = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path
+noHsFileErr :: DynFlags -> SrcSpan -> String -> IO a
+noHsFileErr dflags loc path
+  = throwOneError $ mkPlainErrMsg dflags loc $ text "Can't find" <+> text path
  
-packageModErr :: ModuleName -> IO a
-packageModErr mod
-  = throwOneError $ mkPlainErrMsg noSrcSpan $
+packageModErr :: DynFlags -> ModuleName -> IO a
+packageModErr dflags mod
+  = throwOneError $ mkPlainErrMsg dflags noSrcSpan $
         text "module" <+> quotes (ppr mod) <+> text "is a package module"
 
-multiRootsErr :: [ModSummary] -> IO ()
-multiRootsErr [] = panic "multiRootsErr"
-multiRootsErr summs@(summ1:_)
-  = throwOneError $ mkPlainErrMsg noSrcSpan $
+multiRootsErr :: DynFlags -> [ModSummary] -> IO ()
+multiRootsErr _      [] = panic "multiRootsErr"
+multiRootsErr dflags summs@(summ1:_)
+  = throwOneError $ mkPlainErrMsg dflags noSrcSpan $
         text "module" <+> quotes (ppr mod) <+> 
         text "is defined in multiple files:" <+>
         sep (map text files)
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index 6ea12e51be..91902d6b77 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -64,7 +64,7 @@ getImports :: DynFlags
 getImports dflags buf filename source_filename = do
   let loc  = mkRealSrcLoc (mkFastString filename) 1 1
   case unP parseHeader (mkPState dflags buf loc) of
-    PFailed span err -> parseError span err
+    PFailed span err -> parseError dflags span err
     POk pst rdr_module -> do
       let _ms@(_warns, errs) = getMessages pst
       -- don't log warnings: they'll be reported when we parse the file
@@ -123,8 +123,8 @@ mkPrelImports this_mod loc implicit_prelude import_decls
       		    	       ideclAs        = Nothing,
       		    	       ideclHiding    = Nothing  }
 
-parseError :: SrcSpan -> MsgDoc -> IO a
-parseError span err = throwOneError $ mkPlainErrMsg span err
+parseError :: DynFlags -> SrcSpan -> MsgDoc -> IO a
+parseError dflags span err = throwOneError $ mkPlainErrMsg dflags span err
 
 --------------------------------------------------------------
 -- Get options
@@ -141,7 +141,8 @@ getOptionsFromFile dflags filename
 	      (openBinaryFile filename ReadMode)
               (hClose)
               (\handle -> do
-                  opts <- fmap getOptions' $ lazyGetToks dflags' filename handle
+                  opts <- fmap (getOptions' dflags)
+                               (lazyGetToks dflags' filename handle)
                   seqList opts $ return opts)
     where -- We don't need to get haddock doc tokens when we're just
           -- getting the options from pragmas, and lazily lexing them
@@ -214,15 +215,16 @@ getOptions :: DynFlags
            -> FilePath     -- ^ Source filename.  Used for location info.
            -> [Located String] -- ^ Parsed options.
 getOptions dflags buf filename
-    = getOptions' (getToks dflags filename buf)
+    = getOptions' dflags (getToks dflags filename buf)
 
 -- The token parser is written manually because Happy can't
 -- return a partial result when it encounters a lexer error.
 -- We want to extract options before the buffer is passed through
 -- CPP, so we can't use the same trick as 'getImports'.
-getOptions' :: [Located Token]      -- Input buffer
+getOptions' :: DynFlags
+            -> [Located Token]      -- Input buffer
             -> [Located String]     -- Options.
-getOptions' toks
+getOptions' dflags toks
     = parseToks toks
     where 
           getToken (L _loc tok) = tok
@@ -252,14 +254,14 @@ getOptions' toks
               = parseLanguage xs
           parseToks _ = []
           parseLanguage (L loc (ITconid fs):rest)
-              = checkExtension (L loc fs) :
+              = checkExtension dflags (L loc fs) :
                 case rest of
                   (L _loc ITcomma):more -> parseLanguage more
                   (L _loc ITclose_prag):more -> parseToks more
-                  (L loc _):_ -> languagePragParseError loc
+                  (L loc _):_ -> languagePragParseError dflags loc
                   [] -> panic "getOptions'.parseLanguage(1) went past eof token"
           parseLanguage (tok:_)
-              = languagePragParseError (getLoc tok)
+              = languagePragParseError dflags (getLoc tok)
           parseLanguage []
               = panic "getOptions'.parseLanguage(2) went past eof token"
 
@@ -269,51 +271,51 @@ getOptions' toks
 --
 -- Throws a 'SourceError' if the input list is non-empty claiming that the
 -- input flags are unknown.
-checkProcessArgsResult :: MonadIO m => [Located String] -> m ()
-checkProcessArgsResult flags
+checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()
+checkProcessArgsResult dflags flags
   = when (notNull flags) $
       liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
     where mkMsg (L loc flag)
-              = mkPlainErrMsg loc $
+              = mkPlainErrMsg dflags loc $
                   (text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+>
                    text flag)
 
 -----------------------------------------------------------------------------
 
-checkExtension :: Located FastString -> Located String
-checkExtension (L l ext)
+checkExtension :: DynFlags -> Located FastString -> Located String
+checkExtension dflags (L l ext)
 -- Checks if a given extension is valid, and if so returns
 -- its corresponding flag. Otherwise it throws an exception.
  =  let ext' = unpackFS ext in
     if ext' `elem` supportedLanguagesAndExtensions
     then L l ("-X"++ext')
-    else unsupportedExtnError l ext'
+    else unsupportedExtnError dflags l ext'
 
-languagePragParseError :: SrcSpan -> a
-languagePragParseError loc =
+languagePragParseError :: DynFlags -> SrcSpan -> a
+languagePragParseError dflags loc =
   throw $ mkSrcErr $ unitBag $
-     (mkPlainErrMsg loc $
+     (mkPlainErrMsg dflags loc $
        vcat [ text "Cannot parse LANGUAGE pragma"
             , text "Expecting comma-separated list of language options,"
             , text "each starting with a capital letter"
             , nest 2 (text "E.g. {-# LANGUAGE RecordPuns, Generics #-}") ])
 
-unsupportedExtnError :: SrcSpan -> String -> a
-unsupportedExtnError loc unsup =
+unsupportedExtnError :: DynFlags -> SrcSpan -> String -> a
+unsupportedExtnError dflags loc unsup =
   throw $ mkSrcErr $ unitBag $
-    mkPlainErrMsg loc $
+    mkPlainErrMsg dflags loc $
         text "Unsupported extension: " <> text unsup $$
         if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions)
   where
      suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions
 
 
-optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages
-optionsErrorMsgs unhandled_flags flags_lines _filename
+optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Messages
+optionsErrorMsgs dflags unhandled_flags flags_lines _filename
   = (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
   where	unhandled_flags_lines = [ L l f | f <- unhandled_flags, 
 					  L l f' <- flags_lines, f == f' ]
         mkMsg (L flagSpan flag) = 
-            ErrUtils.mkPlainErrMsg flagSpan $
+            ErrUtils.mkPlainErrMsg dflags flagSpan $
                     text "unknown flag in  {-# OPTIONS_GHC #-} pragma:" <+> text flag
 
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index ba4bfbc7b2..0c09603ae0 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -359,7 +359,7 @@ hscParse' mod_summary = do
 
     case unP parseModule (mkPState dflags buf loc) of
         PFailed span err ->
-            liftIO $ throwOneError (mkPlainErrMsg span err)
+            liftIO $ throwOneError (mkPlainErrMsg dflags span err)
 
         POk pst rdr_module -> do
             logWarningsReportErrors (getMessages pst)
@@ -443,7 +443,7 @@ tcRnModule' hsc_env sum save_rn_syntax mod = do
             safe <- liftIO $ readIORef (tcg_safeInfer tcg_res')
             when (safe && wopt Opt_WarnSafe dflags)
                  (logWarnings $ unitBag $
-                     mkPlainWarnMsg (warnSafeOnLoc dflags) $ errSafe tcg_res')
+                     mkPlainWarnMsg dflags (warnSafeOnLoc dflags) $ errSafe tcg_res')
             return tcg_res'
   where
     pprMod t  = ppr $ moduleName $ tcg_mod t
@@ -919,22 +919,22 @@ hscCheckSafeImports tcg_env = do
     case safeLanguageOn dflags of
         True -> do
             -- we nuke user written RULES in -XSafe
-            logWarnings $ warns (tcg_rules tcg_env')
+            logWarnings $ warns dflags (tcg_rules tcg_env')
             return tcg_env' { tcg_rules = [] }
         False
               -- user defined RULES, so not safe or already unsafe
             | safeInferOn dflags && not (null $ tcg_rules tcg_env') ||
               safeHaskell dflags == Sf_None
-            -> wipeTrust tcg_env' $ warns (tcg_rules tcg_env')
+            -> wipeTrust tcg_env' $ warns dflags (tcg_rules tcg_env')
 
               -- trustworthy OR safe infered with no RULES
             | otherwise
             -> return tcg_env'
 
   where
-    warns rules = listToBag $ map warnRules rules
-    warnRules (L loc (HsRule n _ _ _ _ _ _)) =
-        mkPlainWarnMsg loc $
+    warns dflags rules = listToBag $ map (warnRules dflags) rules
+    warnRules dflags (L loc (HsRule n _ _ _ _ _ _)) =
+        mkPlainWarnMsg dflags loc $
             text "Rule \"" <> ftext n <> text "\" ignored" $+$
             text "User defined rules are disabled under Safe Haskell"
 
@@ -1001,7 +1001,7 @@ checkSafeImports dflags tcg_env
     cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
     cond' v1@(m1,_,l1,s1) (_,_,_,s2)
         | s1 /= s2
-        = throwErrors $ unitBag $ mkPlainErrMsg l1
+        = throwErrors $ unitBag $ mkPlainErrMsg dflags l1
               (text "Module" <+> ppr m1 <+>
               (text $ "is imported both as a safe and unsafe import!"))
         | otherwise
@@ -1040,7 +1040,7 @@ hscCheckSafe' dflags m l = do
         iface <- lookup' m
         case iface of
             -- can't load iface to check trust!
-            Nothing -> throwErrors $ unitBag $ mkPlainErrMsg l
+            Nothing -> throwErrors $ unitBag $ mkPlainErrMsg dflags l
                          $ text "Can't load the interface file for" <+> ppr m
                            <> text ", to check that it can be safely imported"
 
@@ -1062,13 +1062,13 @@ hscCheckSafe' dflags m l = do
                                      return (trust == Sf_Trustworthy, pkgRs)
 
                 where
-                    pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg l $
+                    pkgTrustErr = mkSrcErr $ unitBag $ mkPlainErrMsg dflags l $
                         sep [ ppr (moduleName m)
                                 <> text ": Can't be safely imported!"
                             , text "The package (" <> ppr (modulePackageId m)
                                 <> text ") the module resides in isn't trusted."
                             ]
-                    modTrustErr = unitBag $ mkPlainErrMsg l $
+                    modTrustErr = unitBag $ mkPlainErrMsg dflags l $
                         sep [ ppr (moduleName m)
                                 <> text ": Can't be safely imported!"
                             , text "The module itself isn't safe." ]
@@ -1124,7 +1124,7 @@ checkPkgTrust dflags pkgs =
             | trusted $ getPackageDetails (pkgState dflags) pkg
             = Nothing
             | otherwise
-            = Just $ mkPlainErrMsg noSrcSpan
+            = Just $ mkPlainErrMsg dflags noSrcSpan
                    $ text "The package (" <> ppr pkg <> text ") is required" <>
                      text " to be trusted but it isn't!"
 
@@ -1138,7 +1138,7 @@ wipeTrust tcg_env whyUnsafe = do
 
     when (wopt Opt_WarnUnsafe dflags)
          (logWarnings $ unitBag $
-             mkPlainWarnMsg (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
+             mkPlainWarnMsg dflags (warnUnsafeOnLoc dflags) (whyUnsafe' dflags))
 
     liftIO $ writeIORef (tcg_safeInfer tcg_env) False
     return $ tcg_env { tcg_imports = wiped_trust }
@@ -1538,7 +1538,7 @@ hscImport hsc_env str = runInteractiveHsc hsc_env $ do
     case is of
         [i] -> return (unLoc i)
         _ -> liftIO $ throwOneError $
-                 mkPlainErrMsg noSrcSpan $
+                 mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan $
                      ptext (sLit "parse error in import declaration")
 
 -- | Typecheck an expression (but don't run it)
@@ -1552,7 +1552,7 @@ hscTcExpr hsc_env0 expr = runInteractiveHsc hsc_env0 $ do
         Just (L _ (ExprStmt expr _ _ _)) ->
             ioMsgMaybe $ tcRnExpr hsc_env (hsc_IC hsc_env) expr
         _ ->
-            throwErrors $ unitBag $ mkPlainErrMsg noSrcSpan
+            throwErrors $ unitBag $ mkPlainErrMsg (hsc_dflags hsc_env) noSrcSpan
                 (text "not an expression:" <+> quotes (text expr))
 
 -- | Find the kind of a type
@@ -1597,7 +1597,7 @@ hscParseThingWithLocation source linenumber parser str
 
     case unP parser (mkPState dflags buf loc) of
         PFailed span err -> do
-            let msg = mkPlainErrMsg span err
+            let msg = mkPlainErrMsg dflags span err
             throwErrors $ unitBag msg
 
         POk pst thing -> do
diff --git a/compiler/main/HscTypes.lhs b/compiler/main/HscTypes.lhs
index 1c8276db33..ff618e01be 100644
--- a/compiler/main/HscTypes.lhs
+++ b/compiler/main/HscTypes.lhs
@@ -235,7 +235,7 @@ printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO ()
 printOrThrowWarnings dflags warns
   | dopt Opt_WarnIsError dflags
   = when (not (isEmptyBag warns)) $ do
-      throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg
+      throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg dflags
   | otherwise
   = printBagOfErrors dflags warns
 
@@ -244,7 +244,7 @@ handleFlagWarnings dflags warns
  = when (wopt Opt_WarnDeprecatedFlags dflags) $ do
         -- It would be nicer if warns :: [Located MsgDoc], but that
         -- has circular import problems.
-      let bag = listToBag [ mkPlainWarnMsg loc (text warn)
+      let bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)
                           | L loc warn <- warns ]
 
       printOrThrowWarnings dflags bag
diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index e40f7b2f11..63c8474b0e 100644
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -1960,7 +1960,7 @@ mkPState flags buf loc =
 addWarning :: WarningFlag -> SrcSpan -> SDoc -> P ()
 addWarning option srcspan warning
  = P $ \s@PState{messages=(ws,es), dflags=d} ->
-       let warning' = mkWarnMsg srcspan alwaysQualify warning
+       let warning' = mkWarnMsg d srcspan alwaysQualify warning
            ws' = if wopt option d then ws `snocBag` warning' else ws
        in POk s{messages=(ws', es)} ()
 
diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index c1bdd66bcd..7e6c1d98ae 100644
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -635,7 +635,7 @@ mkLongErrAt loc msg extra
   = do { traceTc "Adding error:" (mkLocMessage SevError loc (msg $$ extra)) ;
          rdr_env <- getGlobalRdrEnv ;
          dflags <- getDynFlags ;
-         return $ mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra }
+         return $ mkLongErrMsg dflags loc (mkPrintUnqualified dflags rdr_env) msg extra }
 
 addLongErrAt :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
 addLongErrAt loc msg extra = mkLongErrAt loc msg extra >>= reportError
@@ -917,7 +917,7 @@ add_warn_at :: SrcSpan -> MsgDoc -> MsgDoc -> TcRn ()
 add_warn_at loc msg extra_info
   = do { rdr_env <- getGlobalRdrEnv ;
          dflags <- getDynFlags ;
-         let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env)
+         let { warn = mkLongWarnMsg dflags loc (mkPrintUnqualified dflags rdr_env)
                                     msg extra_info } ;
          reportWarning warn }