Add defaultLogActionHPrintDoc to DynFlags
authorIan Lynagh <igloo@earth.li>
Mon, 28 May 2012 22:09:20 +0000 (23:09 +0100)
committerIan Lynagh <igloo@earth.li>
Mon, 28 May 2012 22:09:20 +0000 (23:09 +0100)
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

index 31eb368..1f72f8e 100644 (file)
@@ -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 ())