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.

3 files changed, 13 insertions, 2 deletions

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