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

@@ -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}
 
 %************************************************************************

compiler/main/DynFlags.hs

@@ -79,6 +79,7 @@ module DynFlags (
         defaultFatalMessager,
         defaultLogAction,
         defaultLogActionHPrintDoc,
+        defaultLogActionHPutStrDoc,
         defaultFlushOut,
         defaultFlushErr,
 
@@ -1384,22 +1385,30 @@ 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'
                       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 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
     = do let doc = runSDoc d (initSDocContext dflags 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

compiler/main/ErrUtils.lhs

@@ -78,6 +78,7 @@ type MsgDoc = SDoc
 data Severity
   = SevOutput
   | SevDump
+  | SevInteractive
   | SevInfo
   | SevWarning
   | SevError

compiler/main/ErrUtils.lhs-boot

@@ -7,6 +7,7 @@ import SrcLoc (SrcSpan)
 data Severity
   = SevOutput
   | SevDump
+  | SevInteractive
   | SevInfo
   | SevWarning
   | SevError