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.

4 files changed, 18 insertions, 6 deletions

diff --git a/compiler/ghci/Linker.lhs b/compiler/ghci/Linker.lhs
index df82510b62..a409e7f628 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 64ae9b5699..7292ce5cd2 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 3fd92ed473..f9f4387120 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 6f4a373313..fc99c5afde 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