diff options
| author | Phil Ruffwind <rf@rufflewind.com> | 2017-01-10 14:31:55 -0500 |
|---|---|---|
| committer | Ben Gamari <ben@smart-cactus.org> | 2017-01-10 14:32:18 -0500 |
| commit | 22845adcc51b40040b9d526c36d2d36edbb11dd7 (patch) | |
| tree | 788ba7c72b24f4e3054066022be172557331bf0e /compiler/main/DynFlags.hs | |
| parent | 35a5b60390f2a400d06a2209eb03b7fd6ccffdab (diff) | |
| download | haskell-22845adcc51b40040b9d526c36d2d36edbb11dd7.tar.gz | |
Fix terminal corruption bug and clean up SDoc interface.
- Fix #13076 by wrapping `printDoc_` so that the terminal color is
reset even if an exception occurs.
- Add `printSDoc`, `printSDocLn`, and `bufLeftRenderSDoc` to keep `SDoc`
values abstract (they are wrappers of `printDoc_`, `printDoc`, and
`bufLeftRender` respectively).
- Remove unused function: `printForAsm`
Test Plan: manual
Reviewers: RyanGlScott, austin, dfeuer, bgamari
Reviewed By: dfeuer, bgamari
Subscribers: dfeuer, mpickering, thomie
Differential Revision: https://phabricator.haskell.org/D2932
GHC Trac Issues: #13076
Diffstat (limited to 'compiler/main/DynFlags.hs')
| -rw-r--r-- | compiler/main/DynFlags.hs | 15 |
1 files changed, 7 insertions, 8 deletions
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs index 0bc119a783..8d50e01905 100644 --- a/compiler/main/DynFlags.hs +++ b/compiler/main/DynFlags.hs @@ -1697,8 +1697,8 @@ defaultFatalMessager = hPutStrLn stderr defaultLogAction :: LogAction defaultLogAction dflags reason severity srcSpan style msg = case severity of - SevOutput -> printSDoc msg style - SevDump -> printSDoc (msg $$ blankLine) style + SevOutput -> printOut msg style + SevDump -> printOut (msg $$ blankLine) style SevInteractive -> putStrSDoc msg style SevInfo -> printErrs msg style SevFatal -> printErrs msg style @@ -1714,7 +1714,7 @@ defaultLogAction dflags reason severity srcSpan style msg -- whereas converting to string first and using -- hPutStr would just emit the low 8 bits of -- each unicode char. - where printSDoc = defaultLogActionHPrintDoc dflags stdout + where printOut = defaultLogActionHPrintDoc dflags stdout printErrs = defaultLogActionHPrintDoc dflags stderr putStrSDoc = defaultLogActionHPutStrDoc dflags stdout -- Pretty print the warning flag, if any (#10752) @@ -1731,17 +1731,16 @@ defaultLogAction dflags reason severity srcSpan style msg groups -> " (in " ++ intercalate ", " (map ("-W"++) groups) ++ ")" | otherwise = "" +-- | Like 'defaultLogActionHPutStrDoc' but appends an extra newline. defaultLogActionHPrintDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () defaultLogActionHPrintDoc dflags h d sty = defaultLogActionHPutStrDoc dflags h (d $$ text "") sty - -- Adds a newline defaultLogActionHPutStrDoc :: DynFlags -> Handle -> SDoc -> PprStyle -> IO () defaultLogActionHPutStrDoc dflags h d sty - = Pretty.printDoc_ Pretty.PageMode (pprCols dflags) h doc - where -- Don't add a newline at the end, so that successive - -- calls to this log-action can output all on the same line - doc = runSDoc d (initSDocContext dflags sty) + -- Don't add a newline at the end, so that successive + -- calls to this log-action can output all on the same line + = printSDoc Pretty.PageMode dflags h sty d newtype FlushOut = FlushOut (IO ()) |