[commit: ghc] master: Make showSDoc and friends respect -dppr-cols (08a3536)
git at git.haskell.org
git at git.haskell.org
Fri Jan 10 18:17:09 UTC 2014
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/08a3536e4246e323fbcd8040e0b80001950fe9bc/ghc
>---------------------------------------------------------------
commit 08a3536e4246e323fbcd8040e0b80001950fe9bc
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date: Fri Jan 10 18:14:57 2014 +0000
Make showSDoc and friends respect -dppr-cols
Previously they just used a fixed width of 100, ignoring
-dppr-cols. I think this dates back to a time when
the flag didn't exist, or wasn't conveniently available.
Thanks to Andrew Gibiansky for pointing this out.
>---------------------------------------------------------------
08a3536e4246e323fbcd8040e0b80001950fe9bc
compiler/main/DynFlags.hs | 11 ++++-------
compiler/utils/Outputable.lhs | 42 +++++++++++++++++++++--------------------
compiler/utils/Pretty.lhs | 35 ++++++----------------------------
3 files changed, 32 insertions(+), 56 deletions(-)
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 829d303..06d1ed9 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -1480,16 +1480,13 @@ defaultLogAction dflags severity srcSpan style msg
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
+defaultLogActionHPrintDoc = defaultLogActionHPutStrDoc
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
+ = Pretty.printDoc Pretty.PageMode (pprCols dflags) h doc
+ where
+ doc = runSDoc d (initSDocContext dflags sty)
newtype FlushOut = FlushOut (IO ())
diff --git a/compiler/utils/Outputable.lhs b/compiler/utils/Outputable.lhs
index 9cf8c33..8a12670 100644
--- a/compiler/utils/Outputable.lhs
+++ b/compiler/utils/Outputable.lhs
@@ -42,8 +42,7 @@ module Outputable (
pprCode, mkCodeStyle,
showSDoc, showSDocOneLine,
showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine,
- showPpr,
- showSDocUnqual,
+ showSDocUnqual, showPpr,
renderWithStyle,
pprInfixVar, pprPrefixVar,
@@ -366,44 +365,47 @@ mkCodeStyle = PprCode
-- However, Doc *is* an instance of Show
-- showSDoc just blasts it out as a string
showSDoc :: DynFlags -> SDoc -> String
-showSDoc dflags d =
- Pretty.showDocWith PageMode
- (runSDoc d (initSDocContext dflags defaultUserStyle))
+showSDoc dflags sdoc = renderWithStyle dflags sdoc defaultUserStyle
renderWithStyle :: DynFlags -> SDoc -> PprStyle -> String
-renderWithStyle dflags sdoc sty =
- Pretty.render (runSDoc sdoc (initSDocContext dflags sty))
+renderWithStyle dflags sdoc sty
+ = Pretty.showDoc PageMode (pprCols dflags) $
+ runSDoc sdoc (initSDocContext dflags sty)
-- This shows an SDoc, but on one line only. It's cheaper than a full
-- showSDoc, designed for when we're getting results like "Foo.bar"
-- and "foo{uniq strictness}" so we don't want fancy layout anyway.
showSDocOneLine :: DynFlags -> SDoc -> String
showSDocOneLine dflags d
- = Pretty.showDocWith PageMode
- (runSDoc d (initSDocContext dflags defaultUserStyle))
+ = Pretty.showDoc OneLineMode (pprCols dflags) $
+ runSDoc d (initSDocContext dflags defaultUserStyle)
showSDocForUser :: DynFlags -> PrintUnqualified -> SDoc -> String
showSDocForUser dflags unqual doc
- = show (runSDoc doc (initSDocContext dflags (mkUserStyle unqual AllTheWay)))
+ = renderWithStyle dflags doc (mkUserStyle unqual AllTheWay)
showSDocUnqual :: DynFlags -> SDoc -> String
--- Only used in the gruesome isOperator
-showSDocUnqual dflags d
- = show (runSDoc d (initSDocContext dflags (mkUserStyle neverQualify AllTheWay)))
+-- Only used by Haddock
+showSDocUnqual dflags doc
+ = renderWithStyle dflags doc (mkUserStyle neverQualify AllTheWay)
showSDocDump :: DynFlags -> SDoc -> String
-showSDocDump dflags d
- = Pretty.showDocWith PageMode (runSDoc d (initSDocContext dflags defaultDumpStyle))
+showSDocDump dflags d = renderWithStyle dflags d defaultDumpStyle
+
+showSDocDebug :: DynFlags -> SDoc -> String
+showSDocDebug dflags d = renderWithStyle dflags d PprDebug
showSDocDumpOneLine :: DynFlags -> SDoc -> String
showSDocDumpOneLine dflags d
- = Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext dflags PprDump))
-
-showSDocDebug :: DynFlags -> SDoc -> String
-showSDocDebug dflags d = show (runSDoc d (initSDocContext dflags PprDebug))
+ = Pretty.showDoc OneLineMode irrelevantNCols $
+ runSDoc d (initSDocContext dflags PprDump)
showPpr :: Outputable a => DynFlags -> a -> String
-showPpr dflags = showSDoc dflags . ppr
+showPpr dflags thing = showSDoc dflags (ppr thing)
+
+irrelevantNCols :: Int
+-- Used for OneLineMode and LeftMode when number of cols isn't used
+irrelevantNCols = 1
\end{code}
\begin{code}
diff --git a/compiler/utils/Pretty.lhs b/compiler/utils/Pretty.lhs
index 39a78e1..0bac66e 100644
--- a/compiler/utils/Pretty.lhs
+++ b/compiler/utils/Pretty.lhs
@@ -173,8 +173,7 @@ module Pretty (
hang, punctuate,
--- renderStyle, -- Haskell 1.3 only
- render, fullRender, printDoc, showDocWith,
+ fullRender, printDoc, showDoc,
bufLeftRender -- performance hack
) where
@@ -270,9 +269,8 @@ Displaying @Doc@ values.
\begin{code}
instance Show Doc where
- showsPrec _ doc cont = showDoc doc cont
+ showsPrec _ doc cont = showDocPlus PageMode 100 doc cont
-render :: Doc -> String -- Uses default style
fullRender :: Mode
-> Int -- Line length
-> Float -- Ribbons per line
@@ -281,21 +279,10 @@ fullRender :: Mode
-> Doc
-> a -- Result
-{- When we start using 1.3
-renderStyle :: Style -> Doc -> String
-data Style = Style { lineLength :: Int, -- In chars
- ribbonsPerLine :: Float, -- Ratio of ribbon length to line length
- mode :: Mode
- }
-style :: Style -- The default style
-style = Style { lineLength = 100, ribbonsPerLine = 2.5, mode = PageMode }
--}
-
data Mode = PageMode -- Normal
| ZigZagMode -- With zig-zag cuts
| LeftMode -- No indentation, infinitely long lines
| OneLineMode -- All on one line
-
\end{code}
@@ -890,21 +877,11 @@ oneLiner _ = panic "oneLiner: Unhandled case"
\begin{code}
-{-
-renderStyle Style{mode, lineLength, ribbonsPerLine} doc
- = fullRender mode lineLength ribbonsPerLine doc ""
--}
-
-render doc = showDocWith PageMode doc
-
-showDoc :: Doc -> String -> String
-showDoc doc rest = showDocWithAppend PageMode doc rest
-
-showDocWithAppend :: Mode -> Doc -> String -> String
-showDocWithAppend mode doc rest = fullRender mode 100 1.5 string_txt rest doc
+showDocPlus :: Mode -> Int -> Doc -> String -> String
+showDocPlus mode cols doc rest = fullRender mode cols 1.5 string_txt rest doc
-showDocWith :: Mode -> Doc -> String
-showDocWith mode doc = showDocWithAppend mode doc ""
+showDoc :: Mode -> Int -> Doc -> String
+showDoc mode cols doc = showDocPlus mode cols doc ""
string_txt :: TextDetails -> String -> String
string_txt (Chr c) s = c:s
More information about the ghc-commits
mailing list