Start passing DynFlags around inside SDoc

5 files changed, 30 insertions, 15 deletions

diff --git a/compiler/iface/BinIface.hs b/compiler/iface/BinIface.hs
index 134dcfac2c..f01558cafd 100644
--- a/compiler/iface/BinIface.hs
+++ b/compiler/iface/BinIface.hs
@@ -67,7 +67,7 @@ readBinIface_ :: DynFlags -> CheckHiWay -> TraceBinIFaceReading -> FilePath
 readBinIface_ dflags checkHiWay traceBinIFaceReading hi_path update_nc = do
   let printer :: SDoc -> IO ()
       printer = case traceBinIFaceReading of
-                TraceBinIFaceReading -> \sd -> printSDoc sd defaultDumpStyle
+                TraceBinIFaceReading -> \sd -> printSDoc dflags sd defaultDumpStyle
                 QuietBinIFaceReading -> \_ -> return ()
       wantedGot :: Outputable a => String -> a -> a -> IO ()
       wantedGot what wanted got
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 01e0cf8742..5acc7bbbae 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -511,7 +511,7 @@ data DynFlags = DynFlags {
   extensionFlags        :: [ExtensionFlag],
 
   -- | Message output action: use "ErrUtils" instead of this if you can
-  log_action            :: Severity -> SrcSpan -> PprStyle -> Message -> IO (),
+  log_action            :: DynFlags -> Severity -> SrcSpan -> PprStyle -> Message -> IO (),
 
   haddockOptions :: Maybe String
  }
@@ -826,9 +826,9 @@ defaultDynFlags mySettings =
         extensions = [],
         extensionFlags = flattenExtensionFlags Nothing [],
 
-        log_action = \severity srcSpan style msg ->
+        log_action = \dflags severity srcSpan style msg ->
                         case severity of
-                          SevOutput -> printSDoc msg style
+                          SevOutput -> printSDoc dflags msg style
                           SevInfo   -> printErrs msg style
                           SevFatal  -> printErrs msg style
                           _         -> do 
diff --git a/compiler/main/DynFlags.hs-boot b/compiler/main/DynFlags.hs-boot
new file mode 100644
index 0000000000..4c2081fecb
--- /dev/null
+++ b/compiler/main/DynFlags.hs-boot
@@ -0,0 +1,5 @@
+
+module DynFlags (DynFlags) where
+
+data DynFlags
+
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 1c7a389f35..8cc8e62295 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -145,7 +145,7 @@ printBagOfWarnings dflags bag_of_warns =
 printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
 printMsgBag dflags bag sev
   = sequence_   [ let style = mkErrStyle unqual
-		  in log_action dflags sev s style (d $$ e)
+		  in log_action dflags dflags sev s style (d $$ e)
 		| ErrMsg { errMsgSpans = s:_,
 			   errMsgShortDoc = d,
 			   errMsgExtraInfo = e,
@@ -284,30 +284,30 @@ ifVerbose dflags val act
   | otherwise               = return ()
 
 putMsg :: DynFlags -> Message -> IO ()
-putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
+putMsg dflags msg = log_action dflags dflags SevInfo noSrcSpan defaultUserStyle msg
 
 putMsgWith :: DynFlags -> PrintUnqualified -> Message -> IO ()
 putMsgWith dflags print_unqual msg
-  = log_action dflags SevInfo noSrcSpan sty msg
+  = log_action dflags dflags SevInfo noSrcSpan sty msg
   where
     sty = mkUserStyle print_unqual AllTheWay
 
 errorMsg :: DynFlags -> Message -> IO ()
-errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
+errorMsg dflags msg = log_action dflags dflags SevError noSrcSpan defaultErrStyle msg
 
 fatalErrorMsg :: DynFlags -> Message -> IO ()
-fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg
+fatalErrorMsg dflags msg = log_action dflags dflags SevFatal noSrcSpan defaultErrStyle msg
 
 compilationProgressMsg :: DynFlags -> String -> IO ()
 compilationProgressMsg dflags msg
-  = ifVerbose dflags 1 (log_action dflags SevOutput noSrcSpan defaultUserStyle (text msg))
+  = ifVerbose dflags 1 (log_action dflags dflags SevOutput noSrcSpan defaultUserStyle (text msg))
 
 showPass :: DynFlags -> String -> IO ()
 showPass dflags what 
-  = ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
+  = ifVerbose dflags 2 (log_action dflags dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
 
 debugTraceMsg :: DynFlags -> Int -> Message -> IO ()
 debugTraceMsg dflags val msg
-  = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
+  = ifVerbose dflags val (log_action dflags dflags SevInfo noSrcSpan defaultDumpStyle msg)
 
 \end{code}
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index fc4d919473..5dd521adff 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -70,6 +70,7 @@ module Outputable (
 
 import {-# SOURCE #-} 	Module( Module, ModuleName, moduleName )
 import {-# SOURCE #-} 	OccName( OccName )
+import {-# SOURCE #-} DynFlags (DynFlags)
 
 import StaticFlags
 import FastString 
@@ -228,12 +229,21 @@ data SDocContext = SDC
   { sdocStyle      :: !PprStyle
   , sdocLastColour :: !PprColour
     -- ^ The most recently used colour.  This allows nesting colours.
+  , sdocDynFlags   :: DynFlags -- XXX Strictness?
   }
 
 initSDocContext :: PprStyle -> SDocContext
 initSDocContext sty = SDC
   { sdocStyle = sty
   , sdocLastColour = colReset
+  , sdocDynFlags = error "XXX"
+  }
+
+initSDocContext' :: DynFlags -> PprStyle -> SDocContext
+initSDocContext' dflags sty = SDC
+  { sdocStyle = sty
+  , sdocLastColour = colReset
+  , sdocDynFlags = dflags
   }
 
 withPprStyle :: PprStyle -> SDoc -> SDoc
@@ -311,9 +321,9 @@ ifPprDebug d = SDoc $ \ctx -> case ctx of
 
 \begin{code}
 -- Unused [7/02 sof]
-printSDoc :: SDoc -> PprStyle -> IO ()
-printSDoc d sty = do
-  Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext sty))
+printSDoc :: DynFlags -> SDoc -> PprStyle -> IO ()
+printSDoc dflags d sty = do
+  Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext' dflags sty))
   hFlush stdout
 
 -- I'm not sure whether the direct-IO approach of Pretty.printDoc