Make showSDoc and friends respect -dppr-cols
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 10 Jan 2014 18:14:57 +0000 (18:14 +0000)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 10 Jan 2014 18:16:52 +0000 (18:16 +0000)
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.

compiler/main/DynFlags.hs
compiler/utils/Outputable.lhs
compiler/utils/Pretty.lhs

index 829d303..06d1ed9 100644 (file)
@@ -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 ())
 
index 9cf8c33..8a12670 100644 (file)
@@ -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}
index 39a78e1..0bac66e 100644 (file)
@@ -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