[commit: ghc] master: Add defaultLogActionHPrintDoc to DynFlags (a7b1d21)

[Ian Lynagh]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : master

http://hackage.haskell.org/trac/ghc/changeset/a7b1d2198fd23704c394818364a18e5728423fe2

>---------------------------------------------------------------

commit a7b1d2198fd23704c394818364a18e5728423fe2
Author: Ian Lynagh <igloo at earth.li>
Date:   Mon May 28 23:09:20 2012 +0100

    Add defaultLogActionHPrintDoc to DynFlags
    
    We now use this function rather than Outputable.{printSDoc,printErrs}.
    
    Outputable is arguably a better home for the function, but putting it
    in DynFlags should dissuade people from using it inappropriately (in
    particular, nothing other than the default hooks should have stdout
    or stderr hardcoded).
    
    Not exporting it at all would also be an option, but exporting it with
    an ungainly name will make it slightly easier for people who want to
    send output to other Handles for some reason.

>---------------------------------------------------------------

 compiler/main/DynFlags.hs |   27 ++++++++++++++++++---------
 1 files changed, 18 insertions(+), 9 deletions(-)

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 31eb368..1f72f8e 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -66,6 +66,7 @@ module DynFlags (
         defaultDynFlags,                -- Settings -> DynFlags
         initDynFlags,                   -- DynFlags -> IO DynFlags
         defaultLogAction,
+        defaultLogActionHPrintDoc,
         defaultFlushOut,
         defaultFlushErr,
 
@@ -114,6 +115,7 @@ import Constants        ( mAX_CONTEXT_REDUCTION_DEPTH )
 import Panic
 import Util
 import Maybes           ( orElse )
+import qualified Pretty
 import SrcLoc
 import FastString
 import Outputable
@@ -965,15 +967,22 @@ type LogAction = Severity -> SrcSpan -> PprStyle -> MsgDoc -> IO ()
 
 defaultLogAction :: LogAction
 defaultLogAction severity srcSpan style msg
- = case severity of
-   SevOutput -> printSDoc msg style
-   SevInfo   -> printErrs msg style
-   SevFatal  -> printErrs msg style
-   _         -> do hPutChar stderr '\n'
-                   printErrs (mkLocMessage severity srcSpan msg) style
-                   -- careful (#2302): printErrs prints in UTF-8, whereas
-                   -- converting to string first and using hPutStr would
-                   -- just emit the low 8 bits of each unicode char.
+    = case severity of
+      SevOutput -> printSDoc msg style
+      SevInfo   -> printErrs msg style
+      SevFatal  -> printErrs msg style
+      _         -> do hPutChar stderr '\n'
+                      printErrs (mkLocMessage severity srcSpan msg) style
+                      -- careful (#2302): printErrs prints in UTF-8, whereas
+                      -- converting to string first and using hPutStr would
+                      -- just emit the low 8 bits of each unicode char.
+    where printSDoc = defaultLogActionHPrintDoc stdout
+          printErrs = defaultLogActionHPrintDoc stderr
+
+defaultLogActionHPrintDoc :: Handle -> SDoc -> PprStyle -> IO ()
+defaultLogActionHPrintDoc h d sty
+    = do Pretty.printDoc Pretty.PageMode h (runSDoc d (initSDocContext sty))
+         hFlush h
 
 newtype FlushOut = FlushOut (IO ())