[commit: ghc] master: Allow the GHCi messages to be overridden via the GHC API; fixes #7456 (f81e14b)

[Ian Lynagh]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : master

https://github.com/ghc/ghc/commit/f81e14bb14e459cdd59ea232f7c711827be85dd6

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

commit f81e14bb14e459cdd59ea232f7c711827be85dd6
Author: Ian Lynagh <ian at well-typed.com>
Date:   Sun Jun 23 12:49:42 2013 +0100

    Allow the GHCi messages to be overridden via the GHC API; fixes #7456
    
    They now go through log_action. The existing severities all used
    printDoc, which always adds a trailing newline, which we don't
    want for the GHCi messages. I therefore added a new severity
    SevInteractive, which doesn't add a newline.

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

 compiler/ghci/Linker.lhs        |  9 +++++----
 compiler/main/DynFlags.hs       | 13 +++++++++++--
 compiler/main/ErrUtils.lhs      |  1 +
 compiler/main/ErrUtils.lhs-boot |  1 +
 4 files changed, 18 insertions(+), 6 deletions(-)

diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index df82510..a409e7f 100644
--- a/compiler/ghci/Linker.lhs
+++ b/compiler/ghci/Linker.lhs
@@ -1271,12 +1271,13 @@ findFile mk_file_path (dir : dirs)
 
 \begin{code}
 maybePutStr :: DynFlags -> String -> IO ()
-maybePutStr dflags s | verbosity dflags > 0 = putStr s
-                     | otherwise            = return ()
+maybePutStr dflags s
+    = when (verbosity dflags > 0) $
+          do let act = log_action dflags
+             act dflags SevInteractive noSrcSpan defaultUserStyle (text s)
 
 maybePutStrLn :: DynFlags -> String -> IO ()
-maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s
-                       | otherwise            = return ()
+maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")
 \end{code}
 
 %************************************************************************
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 64ae9b5..7292ce5 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -79,6 +79,7 @@ module DynFlags (
         defaultFatalMessager,
         defaultLogAction,
         defaultLogActionHPrintDoc,
+        defaultLogActionHPutStrDoc,
         defaultFlushOut,
         defaultFlushErr,
 
@@ -1384,6 +1385,7 @@ defaultLogAction dflags severity srcSpan style msg
     = case severity of
       SevOutput -> printSDoc msg style
       SevDump   -> printSDoc (msg $$ blankLine) style
+      SevInteractive -> putStrSDoc msg style
       SevInfo   -> printErrs msg style
       SevFatal  -> printErrs msg style
       _         -> do hPutChar stderr '\n'
@@ -1391,8 +1393,9 @@ defaultLogAction dflags severity srcSpan style msg
                       -- 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 dflags stdout
-          printErrs = defaultLogActionHPrintDoc dflags stderr
+    where printSDoc  = defaultLogActionHPrintDoc  dflags stdout
+          printErrs  = defaultLogActionHPrintDoc  dflags stderr
+          putStrSDoc = defaultLogActionHPutStrDoc dflags stdout
 
 defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
 defaultLogActionHPrintDoc dflags h d sty
@@ -1400,6 +1403,12 @@ defaultLogActionHPrintDoc dflags h d sty
          Pretty.printDoc Pretty.PageMode (pprCols dflags) h doc
          hFlush h
 
+defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
+defaultLogActionHPutStrDoc dflags h d sty
+    = do let doc = runSDoc d (initSDocContext dflags sty)
+         hPutStr h (Pretty.render doc)
+         hFlush h
+
 newtype FlushOut = FlushOut (IO ())
 
 defaultFlushOut :: FlushOut
diff --git a/compiler/main/ErrUtils.lhs b/compiler/main/ErrUtils.lhs
index 3fd92ed..f9f4387 100644
--- a/compiler/main/ErrUtils.lhs
+++ b/compiler/main/ErrUtils.lhs
@@ -78,6 +78,7 @@ type MsgDoc = SDoc
 data Severity
   = SevOutput
   | SevDump
+  | SevInteractive
   | SevInfo
   | SevWarning
   | SevError
diff --git a/compiler/main/ErrUtils.lhs-boot b/compiler/main/ErrUtils.lhs-boot
index 6f4a373..fc99c5a 100644
--- a/compiler/main/ErrUtils.lhs-boot
+++ b/compiler/main/ErrUtils.lhs-boot
@@ -7,6 +7,7 @@ import SrcLoc (SrcSpan)
 data Severity
   = SevOutput
   | SevDump
+  | SevInteractive
   | SevInfo
   | SevWarning
   | SevError