Commit f81e14bb authored by ian@well-typed.com's avatar ian@well-typed.com

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.
parent 03fbf8ac
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -78,6 +78,7 @@ type MsgDoc = SDoc
data Severity
= SevOutput
| SevDump
| SevInteractive
| SevInfo
| SevWarning
| SevError
......
......@@ -7,6 +7,7 @@ import SrcLoc (SrcSpan)
data Severity
= SevOutput
| SevDump
| SevInteractive
| SevInfo
| SevWarning
| SevError
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment