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

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) ...@@ -1271,12 +1271,13 @@ findFile mk_file_path (dir : dirs)
\begin{code} \begin{code}
maybePutStr :: DynFlags -> String -> IO () maybePutStr :: DynFlags -> String -> IO ()
maybePutStr dflags s | verbosity dflags > 0 = putStr s maybePutStr dflags s
| otherwise = return () = when (verbosity dflags > 0) $
do let act = log_action dflags
act dflags SevInteractive noSrcSpan defaultUserStyle (text s)
maybePutStrLn :: DynFlags -> String -> IO () maybePutStrLn :: DynFlags -> String -> IO ()
maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s maybePutStrLn dflags s = maybePutStr dflags (s ++ "\n")
| otherwise = return ()
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -79,6 +79,7 @@ module DynFlags ( ...@@ -79,6 +79,7 @@ module DynFlags (
defaultFatalMessager, defaultFatalMessager,
defaultLogAction, defaultLogAction,
defaultLogActionHPrintDoc, defaultLogActionHPrintDoc,
defaultLogActionHPutStrDoc,
defaultFlushOut, defaultFlushOut,
defaultFlushErr, defaultFlushErr,
...@@ -1384,6 +1385,7 @@ defaultLogAction dflags severity srcSpan style msg ...@@ -1384,6 +1385,7 @@ defaultLogAction dflags severity srcSpan style msg
= case severity of = case severity of
SevOutput -> printSDoc msg style SevOutput -> printSDoc msg style
SevDump -> printSDoc (msg $$ blankLine) style SevDump -> printSDoc (msg $$ blankLine) style
SevInteractive -> putStrSDoc msg style
SevInfo -> printErrs msg style SevInfo -> printErrs msg style
SevFatal -> printErrs msg style SevFatal -> printErrs msg style
_ -> do hPutChar stderr '\n' _ -> do hPutChar stderr '\n'
...@@ -1391,8 +1393,9 @@ defaultLogAction dflags severity srcSpan style msg ...@@ -1391,8 +1393,9 @@ defaultLogAction dflags severity srcSpan style msg
-- careful (#2302): printErrs prints in UTF-8, whereas -- careful (#2302): printErrs prints in UTF-8, whereas
-- converting to string first and using hPutStr would -- converting to string first and using hPutStr would
-- just emit the low 8 bits of each unicode char. -- just emit the low 8 bits of each unicode char.
where printSDoc = defaultLogActionHPrintDoc dflags stdout where printSDoc = defaultLogActionHPrintDoc dflags stdout
printErrs = defaultLogActionHPrintDoc dflags stderr printErrs = defaultLogActionHPrintDoc dflags stderr
putStrSDoc = defaultLogActionHPutStrDoc dflags stdout
defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO ()
defaultLogActionHPrintDoc dflags h d sty defaultLogActionHPrintDoc dflags h d sty
...@@ -1400,6 +1403,12 @@ defaultLogActionHPrintDoc dflags h d sty ...@@ -1400,6 +1403,12 @@ defaultLogActionHPrintDoc dflags h d sty
Pretty.printDoc Pretty.PageMode (pprCols dflags) h doc Pretty.printDoc Pretty.PageMode (pprCols dflags) h doc
hFlush h 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 ()) newtype FlushOut = FlushOut (IO ())
defaultFlushOut :: FlushOut defaultFlushOut :: FlushOut
......
...@@ -78,6 +78,7 @@ type MsgDoc = SDoc ...@@ -78,6 +78,7 @@ type MsgDoc = SDoc
data Severity data Severity
= SevOutput = SevOutput
| SevDump | SevDump
| SevInteractive
| SevInfo | SevInfo
| SevWarning | SevWarning
| SevError | SevError
......
...@@ -7,6 +7,7 @@ import SrcLoc (SrcSpan) ...@@ -7,6 +7,7 @@ import SrcLoc (SrcSpan)
data Severity data Severity
= SevOutput = SevOutput
| SevDump | SevDump
| SevInteractive
| SevInfo | SevInfo
| SevWarning | SevWarning
| SevError | 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