never executed always true always false
    1 {-# LANGUAGE BangPatterns #-}
    2 {-# LANGUAGE MagicHash #-}
    3 
    4 -----------------------------------------------------------------------------
    5 -- |
    6 -- Module      :  GHC.Utils.Ppr
    7 -- Copyright   :  (c) The University of Glasgow 2001
    8 -- License     :  BSD-style (see the file LICENSE)
    9 --
   10 -- Maintainer  :  David Terei <code@davidterei.com>
   11 -- Stability   :  stable
   12 -- Portability :  portable
   13 --
   14 -- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators
   15 --
   16 -- Based on /The Design of a Pretty-printing Library/
   17 -- in Advanced Functional Programming,
   18 -- Johan Jeuring and Erik Meijer (eds), LNCS 925
   19 -- <http://www.cse.chalmers.se/~rjmh/Papers/pretty.ps>
   20 --
   21 -----------------------------------------------------------------------------
   22 
   23 {-
   24 Note [Differences between libraries/pretty and compiler/GHC/Utils/Ppr.hs]
   25 
   26 For historical reasons, there are two different copies of `Pretty` in the GHC
   27 source tree:
   28  * `libraries/pretty` is a submodule containing
   29    https://github.com/haskell/pretty. This is the `pretty` library as released
   30    on hackage. It is used by several other libraries in the GHC source tree
   31    (e.g. template-haskell and Cabal).
   32  * `compiler/GHC/Utils/Ppr.hs` (this module). It is used by GHC only.
   33 
   34 There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and
   35 https://gitlab.haskell.org/ghc/ghc/issues/10735 to try to get rid of GHC's copy
   36 of Pretty.
   37 
   38 Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following
   39 major differences:
   40  * GHC's copy uses `Faststring` for performance reasons.
   41  * GHC's copy has received a backported bugfix for #12227, which was
   42    released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside",
   43    https://github.com/haskell/pretty/pull/35).
   44 
   45 Other differences are minor. Both copies define some extra functions and
   46 instances not defined in the other copy. To see all differences, do this in a
   47 ghc git tree:
   48 
   49     $ cd libraries/pretty
   50     $ git checkout v1.1.2.0
   51     $ cd -
   52     $ vimdiff compiler/GHC/Utils/Ppr.hs \
   53               libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs
   54 
   55 For parity with `pretty-1.1.2.1`, the following two `pretty` commits would
   56 have to be backported:
   57   * "Resolve foldr-strictness stack overflow bug"
   58     (307b8173f41cd776eae8f547267df6d72bff2d68)
   59   * "Special-case reduce for horiz/vert"
   60     (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c)
   61 This has not been done sofar, because these commits seem to cause more
   62 allocation in the compiler (see thomie's comments in
   63 https://github.com/haskell/pretty/pull/9).
   64 -}
   65 
   66 module GHC.Utils.Ppr (
   67 
   68         -- * The document type
   69         Doc, TextDetails(..),
   70 
   71         -- * Constructing documents
   72 
   73         -- ** Converting values into documents
   74         char, text, ftext, ptext, ztext, sizedText, zeroWidthText, emptyText,
   75         int, integer, float, double, rational, hex,
   76 
   77         -- ** Simple derived documents
   78         semi, comma, colon, space, equals,
   79         lparen, rparen, lbrack, rbrack, lbrace, rbrace,
   80 
   81         -- ** Wrapping documents in delimiters
   82         parens, brackets, braces, quotes, quote, doubleQuotes,
   83         maybeParens,
   84 
   85         -- ** Combining documents
   86         empty,
   87         (<>), (<+>), hcat, hsep,
   88         ($$), ($+$), vcat,
   89         sep, cat,
   90         fsep, fcat,
   91         nest,
   92         hang, hangNotEmpty, punctuate,
   93 
   94         -- * Predicates on documents
   95         isEmpty,
   96 
   97         -- * Rendering documents
   98 
   99         -- ** Rendering with a particular style
  100         Style(..),
  101         style,
  102         renderStyle,
  103         Mode(..),
  104 
  105         -- ** General rendering
  106         fullRender, txtPrinter,
  107 
  108         -- ** GHC-specific rendering
  109         printDoc, printDoc_,
  110         bufLeftRender -- performance hack
  111 
  112   ) where
  113 
  114 import GHC.Prelude hiding (error)
  115 
  116 import GHC.Utils.BufHandle
  117 import GHC.Data.FastString
  118 import GHC.Utils.Panic.Plain
  119 import System.IO
  120 import Numeric (showHex)
  121 
  122 --for a RULES
  123 import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) )
  124 import GHC.Ptr  ( Ptr(..) )
  125 
  126 -- ---------------------------------------------------------------------------
  127 -- The Doc calculus
  128 
  129 {-
  130 Laws for $$
  131 ~~~~~~~~~~~
  132 <a1>    (x $$ y) $$ z   = x $$ (y $$ z)
  133 <a2>    empty $$ x      = x
  134 <a3>    x $$ empty      = x
  135 
  136         ...ditto $+$...
  137 
  138 Laws for <>
  139 ~~~~~~~~~~~
  140 <b1>    (x <> y) <> z   = x <> (y <> z)
  141 <b2>    empty <> x      = empty
  142 <b3>    x <> empty      = x
  143 
  144         ...ditto <+>...
  145 
  146 Laws for text
  147 ~~~~~~~~~~~~~
  148 <t1>    text s <> text t        = text (s++t)
  149 <t2>    text "" <> x            = x, if x non-empty
  150 
  151 ** because of law n6, t2 only holds if x doesn't
  152 ** start with `nest'.
  153 
  154 
  155 Laws for nest
  156 ~~~~~~~~~~~~~
  157 <n1>    nest 0 x                = x
  158 <n2>    nest k (nest k' x)      = nest (k+k') x
  159 <n3>    nest k (x <> y)         = nest k x <> nest k y
  160 <n4>    nest k (x $$ y)         = nest k x $$ nest k y
  161 <n5>    nest k empty            = empty
  162 <n6>    x <> nest k y           = x <> y, if x non-empty
  163 
  164 ** Note the side condition on <n6>!  It is this that
  165 ** makes it OK for empty to be a left unit for <>.
  166 
  167 Miscellaneous
  168 ~~~~~~~~~~~~~
  169 <m1>    (text s <> x) $$ y = text s <> ((text "" <> x) $$
  170                                          nest (-length s) y)
  171 
  172 <m2>    (x $$ y) <> z = x $$ (y <> z)
  173         if y non-empty
  174 
  175 
  176 Laws for list versions
  177 ~~~~~~~~~~~~~~~~~~~~~~
  178 <l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)
  179         ...ditto hsep, hcat, vcat, fill...
  180 
  181 <l2>    nest k (sep ps) = sep (map (nest k) ps)
  182         ...ditto hsep, hcat, vcat, fill...
  183 
  184 Laws for oneLiner
  185 ~~~~~~~~~~~~~~~~~
  186 <o1>    oneLiner (nest k p) = nest k (oneLiner p)
  187 <o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y
  188 
  189 You might think that the following version of <m1> would
  190 be neater:
  191 
  192 <3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$
  193                                          nest (-length s) y)
  194 
  195 But it doesn't work, for if x=empty, we would have
  196 
  197         text s $$ y = text s <> (empty $$ nest (-length s) y)
  198                     = text s <> nest (-length s) y
  199 -}
  200 
  201 -- ---------------------------------------------------------------------------
  202 -- Operator fixity
  203 
  204 infixl 6 <>
  205 infixl 6 <+>
  206 infixl 5 $$, $+$
  207 
  208 
  209 -- ---------------------------------------------------------------------------
  210 -- The Doc data type
  211 
  212 -- | The abstract type of documents.
  213 -- A Doc represents a *set* of layouts. A Doc with
  214 -- no occurrences of Union or NoDoc represents just one layout.
  215 data Doc
  216   = Empty                                            -- empty
  217   | NilAbove Doc                                     -- text "" $$ x
  218   | TextBeside !TextDetails {-# UNPACK #-} !Int Doc  -- text s <> x
  219   | Nest {-# UNPACK #-} !Int Doc                     -- nest k x
  220   | Union Doc Doc                                    -- ul `union` ur
  221   | NoDoc                                            -- The empty set of documents
  222   | Beside Doc Bool Doc                              -- True <=> space between
  223   | Above Doc Bool Doc                               -- True <=> never overlap
  224 
  225 {-
  226 Here are the invariants:
  227 
  228 1) The argument of NilAbove is never Empty. Therefore
  229    a NilAbove occupies at least two lines.
  230 
  231 2) The argument of @TextBeside@ is never @Nest@.
  232 
  233 3) The layouts of the two arguments of @Union@ both flatten to the same
  234    string.
  235 
  236 4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
  237 
  238 5) A @NoDoc@ may only appear on the first line of the left argument of an
  239    union. Therefore, the right argument of an union can never be equivalent
  240    to the empty set (@NoDoc@).
  241 
  242 6) An empty document is always represented by @Empty@.  It can't be
  243    hidden inside a @Nest@, or a @Union@ of two @Empty@s.
  244 
  245 7) The first line of every layout in the left argument of @Union@ is
  246    longer than the first line of any layout in the right argument.
  247    (1) ensures that the left argument has a first line.  In view of
  248    (3), this invariant means that the right argument must have at
  249    least two lines.
  250 
  251 Notice the difference between
  252    * NoDoc (no documents)
  253    * Empty (one empty document; no height and no width)
  254    * text "" (a document containing the empty string;
  255               one line high, but has no width)
  256 -}
  257 
  258 
  259 -- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside.
  260 type RDoc = Doc
  261 
  262 -- | The TextDetails data type
  263 --
  264 -- A TextDetails represents a fragment of text that will be
  265 -- output at some point.
  266 data TextDetails = Chr  {-# UNPACK #-} !Char -- ^ A single Char fragment
  267                  | Str  String -- ^ A whole String fragment
  268                  | PStr FastString                      -- a hashed string
  269                  | ZStr FastZString                     -- a z-encoded string
  270                  | LStr {-# UNPACK #-} !PtrString
  271                    -- a '\0'-terminated array of bytes
  272                  | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char
  273                    -- a repeated character (e.g., ' ')
  274 
  275 instance Show Doc where
  276   showsPrec _ doc cont = fullRender (mode style) (lineLength style)
  277                                     (ribbonsPerLine style)
  278                                     txtPrinter cont doc
  279 
  280 
  281 -- ---------------------------------------------------------------------------
  282 -- Values and Predicates on GDocs and TextDetails
  283 
  284 -- | A document of height and width 1, containing a literal character.
  285 char :: Char -> Doc
  286 char c = textBeside_ (Chr c) 1 Empty
  287 
  288 -- | A document of height 1 containing a literal string.
  289 -- 'text' satisfies the following laws:
  290 --
  291 -- * @'text' s '<>' 'text' t = 'text' (s'++'t)@
  292 --
  293 -- * @'text' \"\" '<>' x = x@, if @x@ non-empty
  294 --
  295 -- The side condition on the last law is necessary because @'text' \"\"@
  296 -- has height 1, while 'empty' has no height.
  297 text :: String -> Doc
  298 text s = textBeside_ (Str s) (length s) Empty
  299 {-# NOINLINE [0] text #-}   -- Give the RULE a chance to fire
  300                             -- It must wait till after phase 1 when
  301                             -- the unpackCString first is manifested
  302 
  303 -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
  304 -- intermediate packing/unpacking of the string.
  305 {-# RULES "text/str"
  306     forall a. text (unpackCString# a)  = ptext (mkPtrString# a)
  307   #-}
  308 {-# RULES "text/unpackNBytes#"
  309     forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n))
  310   #-}
  311 
  312 -- Empty strings are desugared into [] (not "unpackCString#..."), hence they are
  313 -- not matched by the text/str rule above.
  314 {-# RULES "text/[]"
  315     text [] = emptyText
  316   #-}
  317 
  318 ftext :: FastString -> Doc
  319 ftext s = textBeside_ (PStr s) (lengthFS s) Empty
  320 
  321 ptext :: PtrString -> Doc
  322 ptext s = textBeside_ (LStr s) (lengthPS s) Empty
  323 
  324 ztext :: FastZString -> Doc
  325 ztext s = textBeside_ (ZStr s) (lengthFZS s) Empty
  326 
  327 -- | Some text with any width. (@text s = sizedText (length s) s@)
  328 sizedText :: Int -> String -> Doc
  329 sizedText l s = textBeside_ (Str s) l Empty
  330 
  331 -- | Some text, but without any width. Use for non-printing text
  332 -- such as a HTML or Latex tags
  333 zeroWidthText :: String -> Doc
  334 zeroWidthText = sizedText 0
  335 
  336 -- | Empty text (one line high but no width). (@emptyText = text ""@)
  337 emptyText :: Doc
  338 emptyText = sizedText 0 []
  339   -- defined as a CAF. Sharing occurs especially via the text/[] rule above.
  340   -- Every use of `text ""` in user code should be replaced with this.
  341 
  342 -- | The empty document, with no height and no width.
  343 -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere
  344 -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.
  345 empty :: Doc
  346 empty = Empty
  347 
  348 -- | Returns 'True' if the document is empty
  349 isEmpty :: Doc -> Bool
  350 isEmpty Empty = True
  351 isEmpty _     = False
  352 
  353 {-
  354 Q: What is the reason for negative indentation (i.e. argument to indent
  355    is < 0) ?
  356 
  357 A:
  358 This indicates an error in the library client's code.
  359 If we compose a <> b, and the first line of b is more indented than some
  360 other lines of b, the law <n6> (<> eats nests) may cause the pretty
  361 printer to produce an invalid layout:
  362 
  363 doc       |0123345
  364 ------------------
  365 d1        |a...|
  366 d2        |...b|
  367           |c...|
  368 
  369 d1<>d2    |ab..|
  370          c|....|
  371 
  372 Consider a <> b, let `s' be the length of the last line of `a', `k' the
  373 indentation of the first line of b, and `k0' the indentation of the
  374 left-most line b_i of b.
  375 
  376 The produced layout will have negative indentation if `k - k0 > s', as
  377 the first line of b will be put on the (s+1)th column, effectively
  378 translating b horizontally by (k-s). Now if the i^th line of b has an
  379 indentation k0 < (k-s), it is translated out-of-page, causing
  380 `negative indentation'.
  381 -}
  382 
  383 
  384 semi   :: Doc -- ^ A ';' character
  385 comma  :: Doc -- ^ A ',' character
  386 colon  :: Doc -- ^ A ':' character
  387 space  :: Doc -- ^ A space character
  388 equals :: Doc -- ^ A '=' character
  389 lparen :: Doc -- ^ A '(' character
  390 rparen :: Doc -- ^ A ')' character
  391 lbrack :: Doc -- ^ A '[' character
  392 rbrack :: Doc -- ^ A ']' character
  393 lbrace :: Doc -- ^ A '{' character
  394 rbrace :: Doc -- ^ A '}' character
  395 semi   = char ';'
  396 comma  = char ','
  397 colon  = char ':'
  398 space  = char ' '
  399 equals = char '='
  400 lparen = char '('
  401 rparen = char ')'
  402 lbrack = char '['
  403 rbrack = char ']'
  404 lbrace = char '{'
  405 rbrace = char '}'
  406 
  407 spaceText, nlText :: TextDetails
  408 spaceText = Chr ' '
  409 nlText    = Chr '\n'
  410 
  411 int      :: Int      -> Doc -- ^ @int n = text (show n)@
  412 integer  :: Integer  -> Doc -- ^ @integer n = text (show n)@
  413 float    :: Float    -> Doc -- ^ @float n = text (show n)@
  414 double   :: Double   -> Doc -- ^ @double n = text (show n)@
  415 rational :: Rational -> Doc -- ^ @rational n = text (show n)@
  416 hex      :: Integer  -> Doc -- ^ See Note [Print Hexadecimal Literals]
  417 int      n = text (show n)
  418 integer  n = text (show n)
  419 float    n = text (show n)
  420 double   n = text (show n)
  421 rational n = text (show n)
  422 hex      n = text ('0' : 'x' : padded)
  423     where
  424     str = showHex n ""
  425     strLen = max 1 (length str)
  426     len = 2 ^ (ceiling (logBase 2 (fromIntegral strLen :: Double)) :: Int)
  427     padded = replicate (len - strLen) '0' ++ str
  428 
  429 parens       :: Doc -> Doc -- ^ Wrap document in @(...)@
  430 brackets     :: Doc -> Doc -- ^ Wrap document in @[...]@
  431 braces       :: Doc -> Doc -- ^ Wrap document in @{...}@
  432 quotes       :: Doc -> Doc -- ^ Wrap document in @\'...\'@
  433 quote        :: Doc -> Doc
  434 doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@
  435 quotes p       = char '`' <> p <> char '\''
  436 quote p        = char '\'' <> p
  437 doubleQuotes p = char '"' <> p <> char '"'
  438 parens p       = char '(' <> p <> char ')'
  439 brackets p     = char '[' <> p <> char ']'
  440 braces p       = char '{' <> p <> char '}'
  441 
  442 {-
  443 Note [Print Hexadecimal Literals]
  444 
  445 Relevant discussions:
  446  * Phabricator: https://phabricator.haskell.org/D4465
  447  * GHC Trac: https://gitlab.haskell.org/ghc/ghc/issues/14872
  448 
  449 There is a flag `-dhex-word-literals` that causes literals of
  450 type `Word#` or `Word64#` to be displayed in hexadecimal instead
  451 of decimal when dumping GHC core. It also affects the presentation
  452 of these in GHC's error messages. Additionally, the hexadecimal
  453 encoding of these numbers is zero-padded so that its length is
  454 a power of two. As an example of what this does,
  455 consider the following haskell file `Literals.hs`:
  456 
  457     module Literals where
  458 
  459     alpha :: Int
  460     alpha = 100 + 200
  461 
  462     beta :: Word -> Word
  463     beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202
  464 
  465 We get the following dumped core when we compile on a 64-bit
  466 machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all
  467 -dhex-word-literals literals.hs:
  468 
  469     ==================== Tidy Core ====================
  470 
  471     ... omitted for brevity ...
  472 
  473     -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
  474     alpha
  475     alpha = I# 300#
  476 
  477     -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0}
  478     beta
  479     beta
  480       = \ x_aYE ->
  481           case x_aYE of { W# x#_a1v0 ->
  482           W#
  483             (plusWord#
  484                (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##)
  485                0x0202##)
  486           }
  487 
  488 Notice that the word literals are in hexadecimals and that they have
  489 been padded with zeroes so that their lengths are 16, 8, and 4, respectively.
  490 
  491 -}
  492 
  493 -- | Apply 'parens' to 'Doc' if boolean is true.
  494 maybeParens :: Bool -> Doc -> Doc
  495 maybeParens False = id
  496 maybeParens True = parens
  497 
  498 -- ---------------------------------------------------------------------------
  499 -- Structural operations on GDocs
  500 
  501 -- | Perform some simplification of a built up @GDoc@.
  502 reduceDoc :: Doc -> RDoc
  503 reduceDoc (Beside p g q) = p `seq` g `seq` (beside p g $! reduceDoc q)
  504 reduceDoc (Above  p g q) = p `seq` g `seq` (above  p g $! reduceDoc q)
  505 reduceDoc p              = p
  506 
  507 -- | List version of '<>'.
  508 hcat :: [Doc] -> Doc
  509 hcat = reduceAB . foldr (beside_' False) empty
  510 
  511 -- | List version of '<+>'.
  512 hsep :: [Doc] -> Doc
  513 hsep = reduceAB . foldr (beside_' True)  empty
  514 
  515 -- | List version of '$$'.
  516 vcat :: [Doc] -> Doc
  517 vcat = reduceAB . foldr (above_' False) empty
  518 
  519 -- | Nest (or indent) a document by a given number of positions
  520 -- (which may also be negative).  'nest' satisfies the laws:
  521 --
  522 -- * @'nest' 0 x = x@
  523 --
  524 -- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@
  525 --
  526 -- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@
  527 --
  528 -- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@
  529 --
  530 -- * @'nest' k 'empty' = 'empty'@
  531 --
  532 -- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty
  533 --
  534 -- The side condition on the last law is needed because
  535 -- 'empty' is a left identity for '<>'.
  536 nest :: Int -> Doc -> Doc
  537 nest k p = mkNest k (reduceDoc p)
  538 
  539 -- | @hang d1 n d2 = sep [d1, nest n d2]@
  540 hang :: Doc -> Int -> Doc -> Doc
  541 hang d1 n d2 = sep [d1, nest n d2]
  542 
  543 -- | Apply 'hang' to the arguments if the first 'Doc' is not empty.
  544 hangNotEmpty :: Doc -> Int -> Doc -> Doc
  545 hangNotEmpty d1 n d2 = if isEmpty d1
  546                        then d2
  547                        else hang d1 n d2
  548 
  549 -- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
  550 punctuate :: Doc -> [Doc] -> [Doc]
  551 punctuate _ []     = []
  552 punctuate p (x:xs) = go x xs
  553                    where go y []     = [y]
  554                          go y (z:zs) = (y <> p) : go z zs
  555 
  556 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
  557 mkNest :: Int -> Doc -> Doc
  558 mkNest k _ | k `seq` False = undefined
  559 mkNest k (Nest k1 p)       = mkNest (k + k1) p
  560 mkNest _ NoDoc             = NoDoc
  561 mkNest _ Empty             = Empty
  562 mkNest 0 p                 = p
  563 mkNest k p                 = nest_ k p
  564 
  565 -- mkUnion checks for an empty document
  566 mkUnion :: Doc -> Doc -> Doc
  567 mkUnion Empty _ = Empty
  568 mkUnion p q     = p `union_` q
  569 
  570 beside_' :: Bool -> Doc -> Doc -> Doc
  571 beside_' _ p Empty = p
  572 beside_' g p q     = Beside p g q
  573 
  574 above_' :: Bool -> Doc -> Doc -> Doc
  575 above_' _ p Empty = p
  576 above_' g p q     = Above p g q
  577 
  578 reduceAB :: Doc -> Doc
  579 reduceAB (Above  Empty _ q) = q
  580 reduceAB (Beside Empty _ q) = q
  581 reduceAB doc                = doc
  582 
  583 nilAbove_ :: RDoc -> RDoc
  584 nilAbove_ = NilAbove
  585 
  586 -- Arg of a TextBeside is always an RDoc
  587 textBeside_ :: TextDetails -> Int -> RDoc -> RDoc
  588 textBeside_ = TextBeside
  589 
  590 nest_ :: Int -> RDoc -> RDoc
  591 nest_ = Nest
  592 
  593 union_ :: RDoc -> RDoc -> RDoc
  594 union_ = Union
  595 
  596 
  597 -- ---------------------------------------------------------------------------
  598 -- Vertical composition @$$@
  599 
  600 -- | Above, except that if the last line of the first argument stops
  601 -- at least one position before the first line of the second begins,
  602 -- these two lines are overlapped.  For example:
  603 --
  604 -- >    text "hi" $$ nest 5 (text "there")
  605 --
  606 -- lays out as
  607 --
  608 -- >    hi   there
  609 --
  610 -- rather than
  611 --
  612 -- >    hi
  613 -- >         there
  614 --
  615 -- '$$' is associative, with identity 'empty', and also satisfies
  616 --
  617 -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.
  618 --
  619 ($$) :: Doc -> Doc -> Doc
  620 p $$  q = above_ p False q
  621 
  622 -- | Above, with no overlapping.
  623 -- '$+$' is associative, with identity 'empty'.
  624 ($+$) :: Doc -> Doc -> Doc
  625 p $+$ q = above_ p True q
  626 
  627 above_ :: Doc -> Bool -> Doc -> Doc
  628 above_ p _ Empty = p
  629 above_ Empty _ q = q
  630 above_ p g q     = Above p g q
  631 
  632 above :: Doc -> Bool -> RDoc -> RDoc
  633 above (Above p g1 q1)  g2 q2 = above p g1 (above q1 g2 q2)
  634 above p@(Beside{})     g  q  = aboveNest (reduceDoc p) g 0 (reduceDoc q)
  635 above p g q                  = aboveNest p             g 0 (reduceDoc q)
  636 
  637 -- Specification: aboveNest p g k q = p $g$ (nest k q)
  638 aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
  639 aboveNest _                   _ k _ | k `seq` False = undefined
  640 aboveNest NoDoc               _ _ _ = NoDoc
  641 aboveNest (p1 `Union` p2)     g k q = aboveNest p1 g k q `union_`
  642                                       aboveNest p2 g k q
  643 
  644 aboveNest Empty               _ k q = mkNest k q
  645 aboveNest (Nest k1 p)         g k q = nest_ k1 (aboveNest p g (k - k1) q)
  646                                   -- p can't be Empty, so no need for mkNest
  647 
  648 aboveNest (NilAbove p)        g k q = nilAbove_ (aboveNest p g k q)
  649 aboveNest (TextBeside s sl p) g k q = textBeside_ s sl rest
  650                                     where
  651                                       !k1  = k - sl
  652                                       rest = case p of
  653                                                 Empty -> nilAboveNest g k1 q
  654                                                 _     -> aboveNest  p g k1 q
  655 aboveNest (Above {})          _ _ _ = error "aboveNest Above"
  656 aboveNest (Beside {})         _ _ _ = error "aboveNest Beside"
  657 
  658 -- Specification: text s <> nilaboveNest g k q
  659 --              = text s <> (text "" $g$ nest k q)
  660 nilAboveNest :: Bool -> Int -> RDoc -> RDoc
  661 nilAboveNest _ k _           | k `seq` False = undefined
  662 nilAboveNest _ _ Empty       = Empty
  663                                -- Here's why the "text s <>" is in the spec!
  664 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
  665 nilAboveNest g k q           | not g && k > 0      -- No newline if no overlap
  666                              = textBeside_ (RStr k ' ') k q
  667                              | otherwise           -- Put them really above
  668                              = nilAbove_ (mkNest k q)
  669 
  670 
  671 -- ---------------------------------------------------------------------------
  672 -- Horizontal composition @<>@
  673 
  674 -- We intentionally avoid Data.Monoid.(<>) here due to interactions of
  675 -- Data.Monoid.(<>) and (<+>).  See
  676 -- http://www.haskell.org/pipermail/libraries/2011-November/017066.html
  677 
  678 -- | Beside.
  679 -- '<>' is associative, with identity 'empty'.
  680 (<>) :: Doc -> Doc -> Doc
  681 p <>  q = beside_ p False q
  682 
  683 -- | Beside, separated by space, unless one of the arguments is 'empty'.
  684 -- '<+>' is associative, with identity 'empty'.
  685 (<+>) :: Doc -> Doc -> Doc
  686 p <+> q = beside_ p True  q
  687 
  688 beside_ :: Doc -> Bool -> Doc -> Doc
  689 beside_ p _ Empty = p
  690 beside_ Empty _ q = q
  691 beside_ p g q     = Beside p g q
  692 
  693 -- Specification: beside g p q = p <g> q
  694 beside :: Doc -> Bool -> RDoc -> RDoc
  695 beside NoDoc               _ _   = NoDoc
  696 beside (p1 `Union` p2)     g q   = beside p1 g q `union_` beside p2 g q
  697 beside Empty               _ q   = q
  698 beside (Nest k p)          g q   = nest_ k $! beside p g q
  699 beside p@(Beside p1 g1 q1) g2 q2
  700          | g1 == g2              = beside p1 g1 $! beside q1 g2 q2
  701          | otherwise             = beside (reduceDoc p) g2 q2
  702 beside p@(Above{})         g q   = let !d = reduceDoc p in beside d g q
  703 beside (NilAbove p)        g q   = nilAbove_ $! beside p g q
  704 beside (TextBeside s sl p) g q   = textBeside_ s sl rest
  705                                where
  706                                   rest = case p of
  707                                            Empty -> nilBeside g q
  708                                            _     -> beside p g q
  709 
  710 -- Specification: text "" <> nilBeside g p
  711 --              = text "" <g> p
  712 nilBeside :: Bool -> RDoc -> RDoc
  713 nilBeside _ Empty         = Empty -- Hence the text "" in the spec
  714 nilBeside g (Nest _ p)    = nilBeside g p
  715 nilBeside g p | g         = textBeside_ spaceText 1 p
  716               | otherwise = p
  717 
  718 
  719 -- ---------------------------------------------------------------------------
  720 -- Separate, @sep@
  721 
  722 -- Specification: sep ps  = oneLiner (hsep ps)
  723 --                         `union`
  724 --                          vcat ps
  725 
  726 -- | Either 'hsep' or 'vcat'.
  727 sep  :: [Doc] -> Doc
  728 sep = sepX True   -- Separate with spaces
  729 
  730 -- | Either 'hcat' or 'vcat'.
  731 cat :: [Doc] -> Doc
  732 cat = sepX False  -- Don't
  733 
  734 sepX :: Bool -> [Doc] -> Doc
  735 sepX _ []     = empty
  736 sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
  737 
  738 
  739 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
  740 --                            = oneLiner (x <g> nest k (hsep ys))
  741 --                              `union` x $$ nest k (vcat ys)
  742 sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
  743 sep1 _ _                   k _  | k `seq` False = undefined
  744 sep1 _ NoDoc               _ _  = NoDoc
  745 sep1 g (p `Union` q)       k ys = sep1 g p k ys `union_`
  746                                   aboveNest q False k (reduceDoc (vcat ys))
  747 
  748 sep1 g Empty               k ys = mkNest k (sepX g ys)
  749 sep1 g (Nest n p)          k ys = nest_ n (sep1 g p (k - n) ys)
  750 
  751 sep1 _ (NilAbove p)        k ys = nilAbove_
  752                                   (aboveNest p False k (reduceDoc (vcat ys)))
  753 sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys)
  754 sep1 _ (Above {})          _ _  = error "sep1 Above"
  755 sep1 _ (Beside {})         _ _  = error "sep1 Beside"
  756 
  757 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
  758 -- Called when we have already found some text in the first item
  759 -- We have to eat up nests
  760 sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
  761 sepNB g (Nest _ p) k ys
  762   = sepNB g p k ys -- Never triggered, because of invariant (2)
  763 sepNB g Empty k ys
  764   = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion`
  765     -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
  766     nilAboveNest False k (reduceDoc (vcat ys))
  767   where
  768     rest | g         = hsep ys
  769          | otherwise = hcat ys
  770 sepNB g p k ys
  771   = sep1 g p k ys
  772 
  773 
  774 -- ---------------------------------------------------------------------------
  775 -- @fill@
  776 
  777 -- | \"Paragraph fill\" version of 'cat'.
  778 fcat :: [Doc] -> Doc
  779 fcat = fill False
  780 
  781 -- | \"Paragraph fill\" version of 'sep'.
  782 fsep :: [Doc] -> Doc
  783 fsep = fill True
  784 
  785 -- Specification:
  786 --
  787 -- fill g docs = fillIndent 0 docs
  788 --
  789 -- fillIndent k [] = []
  790 -- fillIndent k [p] = p
  791 -- fillIndent k (p1:p2:ps) =
  792 --    oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0)
  793 --                               (remove_nests (oneLiner p2) : ps)
  794 --     `Union`
  795 --    (p1 $*$ nest (-k) (fillIndent 0 ps))
  796 --
  797 -- $*$ is defined for layouts (not Docs) as
  798 -- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2
  799 --                     | otherwise                  = layout1 $+$ layout2
  800 
  801 fill :: Bool -> [Doc] -> RDoc
  802 fill _ []     = empty
  803 fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
  804 
  805 fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
  806 fill1 _ _                   k _  | k `seq` False = undefined
  807 fill1 _ NoDoc               _ _  = NoDoc
  808 fill1 g (p `Union` q)       k ys = fill1 g p k ys `union_`
  809                                    aboveNest q False k (fill g ys)
  810 fill1 g Empty               k ys = mkNest k (fill g ys)
  811 fill1 g (Nest n p)          k ys = nest_ n (fill1 g p (k - n) ys)
  812 fill1 g (NilAbove p)        k ys = nilAbove_ (aboveNest p False k (fill g ys))
  813 fill1 g (TextBeside s sl p) k ys = textBeside_ s sl (fillNB g p (k - sl) ys)
  814 fill1 _ (Above {})          _ _  = error "fill1 Above"
  815 fill1 _ (Beside {})         _ _  = error "fill1 Beside"
  816 
  817 fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
  818 fillNB _ _           k _  | k `seq` False = undefined
  819 fillNB g (Nest _ p)  k ys   = fillNB g p k ys
  820                               -- Never triggered, because of invariant (2)
  821 fillNB _ Empty _ []         = Empty
  822 fillNB g Empty k (Empty:ys) = fillNB g Empty k ys
  823 fillNB g Empty k (y:ys)     = fillNBE g k y ys
  824 fillNB g p k ys             = fill1 g p k ys
  825 
  826 
  827 fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc
  828 fillNBE g k y ys
  829   = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys)
  830     -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
  831     `mkUnion` nilAboveNest False k (fill g (y:ys))
  832   where k' = if g then k - 1 else k
  833 
  834 elideNest :: Doc -> Doc
  835 elideNest (Nest _ d) = d
  836 elideNest d          = d
  837 
  838 -- ---------------------------------------------------------------------------
  839 -- Selecting the best layout
  840 
  841 best :: Int   -- Line length
  842      -> Int   -- Ribbon length
  843      -> RDoc
  844      -> RDoc  -- No unions in here!
  845 best w0 r = get w0
  846   where
  847     get :: Int          -- (Remaining) width of line
  848         -> Doc -> Doc
  849     get w _ | w == 0 && False = undefined
  850     get _ Empty               = Empty
  851     get _ NoDoc               = NoDoc
  852     get w (NilAbove p)        = nilAbove_ (get w p)
  853     get w (TextBeside s sl p) = textBeside_ s sl (get1 w sl p)
  854     get w (Nest k p)          = nest_ k (get (w - k) p)
  855     get w (p `Union` q)       = nicest w r (get w p) (get w q)
  856     get _ (Above {})          = error "best get Above"
  857     get _ (Beside {})         = error "best get Beside"
  858 
  859     get1 :: Int         -- (Remaining) width of line
  860          -> Int         -- Amount of first line already eaten up
  861          -> Doc         -- This is an argument to TextBeside => eat Nests
  862          -> Doc         -- No unions in here!
  863 
  864     get1 w _ _ | w == 0 && False  = undefined
  865     get1 _ _  Empty               = Empty
  866     get1 _ _  NoDoc               = NoDoc
  867     get1 w sl (NilAbove p)        = nilAbove_ (get (w - sl) p)
  868     get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p)
  869     get1 w sl (Nest _ p)          = get1 w sl p
  870     get1 w sl (p `Union` q)       = nicest1 w r sl (get1 w sl p)
  871                                                    (get1 w sl q)
  872     get1 _ _  (Above {})          = error "best get1 Above"
  873     get1 _ _  (Beside {})         = error "best get1 Beside"
  874 
  875 nicest :: Int -> Int -> Doc -> Doc -> Doc
  876 nicest !w !r = nicest1 w r 0
  877 
  878 nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
  879 nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p
  880                       | otherwise                 = q
  881 
  882 fits :: Int  -- Space available
  883      -> Doc
  884      -> Bool -- True if *first line* of Doc fits in space available
  885 fits n _ | n < 0           = False
  886 fits _ NoDoc               = False
  887 fits _ Empty               = True
  888 fits _ (NilAbove _)        = True
  889 fits n (TextBeside _ sl p) = fits (n - sl) p
  890 fits _ (Above {})          = error "fits Above"
  891 fits _ (Beside {})         = error "fits Beside"
  892 fits _ (Union {})          = error "fits Union"
  893 fits _ (Nest {})           = error "fits Nest"
  894 
  895 -- | @first@ returns its first argument if it is non-empty, otherwise its second.
  896 first :: Doc -> Doc -> Doc
  897 first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused
  898           | otherwise     = q
  899 
  900 nonEmptySet :: Doc -> Bool
  901 nonEmptySet NoDoc              = False
  902 nonEmptySet (_ `Union` _)      = True
  903 nonEmptySet Empty              = True
  904 nonEmptySet (NilAbove _)       = True
  905 nonEmptySet (TextBeside _ _ p) = nonEmptySet p
  906 nonEmptySet (Nest _ p)         = nonEmptySet p
  907 nonEmptySet (Above {})         = error "nonEmptySet Above"
  908 nonEmptySet (Beside {})        = error "nonEmptySet Beside"
  909 
  910 -- @oneLiner@ returns the one-line members of the given set of @GDoc@s.
  911 oneLiner :: Doc -> Doc
  912 oneLiner NoDoc               = NoDoc
  913 oneLiner Empty               = Empty
  914 oneLiner (NilAbove _)        = NoDoc
  915 oneLiner (TextBeside s sl p) = textBeside_ s sl (oneLiner p)
  916 oneLiner (Nest k p)          = nest_ k (oneLiner p)
  917 oneLiner (p `Union` _)       = oneLiner p
  918 oneLiner (Above {})          = error "oneLiner Above"
  919 oneLiner (Beside {})         = error "oneLiner Beside"
  920 
  921 
  922 -- ---------------------------------------------------------------------------
  923 -- Rendering
  924 
  925 -- | A rendering style.
  926 data Style
  927   = Style { mode           :: Mode  -- ^ The rendering mode
  928           , lineLength     :: Int   -- ^ Length of line, in chars
  929           , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length
  930           }
  931 
  932 -- | The default style (@mode=PageMode False, lineLength=100, ribbonsPerLine=1.5@).
  933 style :: Style
  934 style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode False }
  935 
  936 -- | Rendering mode.
  937 data Mode = PageMode { asciiSpace :: Bool }    -- ^ Normal
  938           | ZigZagMode   -- ^ With zig-zag cuts
  939           | LeftMode     -- ^ No indentation, infinitely long lines
  940           | OneLineMode  -- ^ All on one line
  941 
  942 -- | Can we output an ascii space character for spaces?
  943 --   Mostly true, but not for e.g. UTF16
  944 --   See Note [putSpaces optimizations] for why we bother
  945 --   to track this.
  946 hasAsciiSpace :: Mode -> Bool
  947 hasAsciiSpace mode =
  948   case mode of
  949     PageMode asciiSpace -> asciiSpace
  950     _ -> False
  951 
  952 -- | Render the @Doc@ to a String using the given @Style@.
  953 renderStyle :: Style -> Doc -> String
  954 renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)
  955                 txtPrinter ""
  956 
  957 -- | Default TextDetails printer
  958 txtPrinter :: TextDetails -> String -> String
  959 txtPrinter (Chr c)    s  = c:s
  960 txtPrinter (Str s1)   s2 = s1 ++ s2
  961 txtPrinter (PStr s1)  s2 = unpackFS s1 ++ s2
  962 txtPrinter (ZStr s1)  s2 = zString s1 ++ s2
  963 txtPrinter (LStr s1)  s2 = unpackPtrString s1 ++ s2
  964 txtPrinter (RStr n c) s2 = replicate n c ++ s2
  965 
  966 -- | The general rendering interface.
  967 fullRender :: Mode                     -- ^ Rendering mode
  968            -> Int                      -- ^ Line length
  969            -> Float                    -- ^ Ribbons per line
  970            -> (TextDetails -> a -> a)  -- ^ What to do with text
  971            -> a                        -- ^ What to do at the end
  972            -> Doc                      -- ^ The document
  973            -> a                        -- ^ Result
  974 fullRender OneLineMode _ _ txt end doc
  975   = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc)
  976 fullRender LeftMode    _ _ txt end doc
  977   = easyDisplay nlText first txt end (reduceDoc doc)
  978 
  979 fullRender m lineLen ribbons txt rest doc
  980   = display m lineLen ribbonLen txt rest doc'
  981   where
  982     doc' = best bestLineLen ribbonLen (reduceDoc doc)
  983 
  984     bestLineLen, ribbonLen :: Int
  985     ribbonLen   = round (fromIntegral lineLen / ribbons)
  986     bestLineLen = case m of
  987                       ZigZagMode -> maxBound
  988                       _          -> lineLen
  989 
  990 easyDisplay :: TextDetails
  991              -> (Doc -> Doc -> Doc)
  992              -> (TextDetails -> a -> a)
  993              -> a
  994              -> Doc
  995              -> a
  996 easyDisplay nlSpaceText choose txt end
  997   = lay
  998   where
  999     lay NoDoc              = error "easyDisplay: NoDoc"
 1000     lay (Union p q)        = lay (choose p q)
 1001     lay (Nest _ p)         = lay p
 1002     lay Empty              = end
 1003     lay (NilAbove p)       = nlSpaceText `txt` lay p
 1004     lay (TextBeside s _ p) = s `txt` lay p
 1005     lay (Above {})         = error "easyDisplay Above"
 1006     lay (Beside {})        = error "easyDisplay Beside"
 1007 
 1008 display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
 1009 display m !page_width !ribbon_width txt end doc
 1010   = case page_width - ribbon_width of { gap_width ->
 1011     case gap_width `quot` 2 of { shift ->
 1012     let
 1013         lay k _            | k `seq` False = undefined
 1014         lay k (Nest k1 p)  = lay (k + k1) p
 1015         lay _ Empty        = end
 1016         lay k (NilAbove p) = nlText `txt` lay k p
 1017         lay k (TextBeside s sl p)
 1018             = case m of
 1019                     ZigZagMode |  k >= gap_width
 1020                                -> nlText `txt` (
 1021                                   Str (replicate shift '/') `txt` (
 1022                                   nlText `txt`
 1023                                   lay1 (k - shift) s sl p ))
 1024 
 1025                                |  k < 0
 1026                                -> nlText `txt` (
 1027                                   Str (replicate shift '\\') `txt` (
 1028                                   nlText `txt`
 1029                                   lay1 (k + shift) s sl p ))
 1030 
 1031                     _ -> lay1 k s sl p
 1032         lay _ (Above {})   = error "display lay Above"
 1033         lay _ (Beside {})  = error "display lay Beside"
 1034         lay _ NoDoc        = error "display lay NoDoc"
 1035         lay _ (Union {})   = error "display lay Union"
 1036 
 1037         lay1 !k s !sl p    = let !r = k + sl
 1038                              in indent k (s `txt` lay2 r p)
 1039 
 1040         lay2 k _ | k `seq` False   = undefined
 1041         lay2 k (NilAbove p)        = nlText `txt` lay k p
 1042         lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p
 1043         lay2 k (Nest _ p)          = lay2 k p
 1044         lay2 _ Empty               = end
 1045         lay2 _ (Above {})          = error "display lay2 Above"
 1046         lay2 _ (Beside {})         = error "display lay2 Beside"
 1047         lay2 _ NoDoc               = error "display lay2 NoDoc"
 1048         lay2 _ (Union {})          = error "display lay2 Union"
 1049 
 1050         indent !n r                = RStr n ' ' `txt` r
 1051     in
 1052     lay 0 doc
 1053     }}
 1054 
 1055 printDoc :: Mode -> Int -> Handle -> Doc -> IO ()
 1056 -- printDoc adds a newline to the end
 1057 printDoc mode cols hdl doc = printDoc_ mode cols hdl (doc $$ text "")
 1058 
 1059 {- Note [putSpaces optimizations]
 1060    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 1061 
 1062 When using dump flags a lot of what we are dumping ends up being whitespace.
 1063 This is especially true for Core/Stg dumps. Enough so that it's worth optimizing.
 1064 
 1065 Especially in the common case of writing to an UTF8 or similarly encoded file
 1066 where space is equal to ascii space we use hPutBuf to write a preallocated
 1067 buffer to the file. This avoids a fair bit of allocation.
 1068 
 1069 For other cases we fall back to the old and slow path for simplicity.
 1070 
 1071 -}
 1072 
 1073 printDoc_ :: Mode -> Int -> Handle -> Doc -> IO ()
 1074 -- printDoc_ does not add a newline at the end, so that
 1075 -- successive calls can output stuff on the same line
 1076 -- Rather like putStr vs putStrLn
 1077 printDoc_ LeftMode _ hdl doc
 1078   = do { printLeftRender hdl doc; hFlush hdl }
 1079 printDoc_ mode pprCols hdl doc
 1080   = do { fullRender mode pprCols 1.5 put done doc ;
 1081          hFlush hdl }
 1082   where
 1083     put (Chr c)    next = hPutChar hdl c >> next
 1084     put (Str s)    next = hPutStr  hdl s >> next
 1085     put (PStr s)   next = hPutStr  hdl (unpackFS s) >> next
 1086                           -- NB. not hPutFS, we want this to go through
 1087                           -- the I/O library's encoding layer. (#3398)
 1088     put (ZStr s)   next = hPutFZS  hdl s >> next
 1089     put (LStr s)   next = hPutPtrString hdl s >> next
 1090     put (RStr n c) next
 1091       | c == ' '
 1092       = putSpaces n >> next
 1093       | otherwise
 1094       = hPutStr hdl (replicate n c) >> next
 1095     putSpaces n
 1096       -- If we use ascii spaces we are allowed to use hPutBuf
 1097       -- See Note [putSpaces optimizations]
 1098       | hasAsciiSpace mode
 1099       , n <= 100
 1100       = hPutBuf hdl (Ptr spaces') n
 1101       | hasAsciiSpace mode
 1102       , n > 100
 1103       = hPutBuf hdl (Ptr spaces') 100 >> putSpaces (n-100)
 1104 
 1105       | otherwise = hPutStr hdl (replicate n ' ')
 1106 
 1107     done = return () -- hPutChar hdl '\n'
 1108     -- 100 spaces, so we avoid the allocation of replicate n ' '
 1109     spaces' = "                                                                                                    "#
 1110 
 1111 
 1112   -- some versions of hPutBuf will barf if the length is zero
 1113 hPutPtrString :: Handle -> PtrString -> IO ()
 1114 hPutPtrString _handle (PtrString _ 0) = return ()
 1115 hPutPtrString handle  (PtrString a l) = hPutBuf handle a l
 1116 
 1117 -- Printing output in LeftMode is performance critical: it's used when
 1118 -- dumping C and assembly output, so we allow ourselves a few dirty
 1119 -- hacks:
 1120 --
 1121 -- (1) we specialise fullRender for LeftMode with IO output.
 1122 --
 1123 -- (2) we add a layer of buffering on top of Handles.  Handles
 1124 --     don't perform well with lots of hPutChars, which is mostly
 1125 --     what we're doing here, because Handles have to be thread-safe
 1126 --     and async exception-safe.  We only have a single thread and don't
 1127 --     care about exceptions, so we add a layer of fast buffering
 1128 --     over the Handle interface.
 1129 
 1130 printLeftRender :: Handle -> Doc -> IO ()
 1131 printLeftRender hdl doc = do
 1132   b <- newBufHandle hdl
 1133   bufLeftRender b doc
 1134   bFlush b
 1135 
 1136 bufLeftRender :: BufHandle -> Doc -> IO ()
 1137 bufLeftRender b doc = layLeft b (reduceDoc doc)
 1138 
 1139 layLeft :: BufHandle -> Doc -> IO ()
 1140 layLeft b _ | b `seq` False  = undefined -- make it strict in b
 1141 layLeft _ NoDoc              = error "layLeft: NoDoc"
 1142 layLeft b (Union p q)        = layLeft b $! first p q
 1143 layLeft b (Nest _ p)         = layLeft b $! p
 1144 layLeft b Empty              = bPutChar b '\n'
 1145 layLeft b (NilAbove p)       = p `seq` (bPutChar b '\n' >> layLeft b p)
 1146 layLeft b (TextBeside s _ p) = s `seq` (put b s >> layLeft b p)
 1147  where
 1148     put b _ | b `seq` False = undefined
 1149     put b (Chr c)    = bPutChar b c
 1150     put b (Str s)    = bPutStr  b s
 1151     put b (PStr s)   = bPutFS   b s
 1152     put b (ZStr s)   = bPutFZS  b s
 1153     put b (LStr s)   = bPutPtrString b s
 1154     put b (RStr n c) = bPutReplicate b n c
 1155 layLeft _ _                  = panic "layLeft: Unhandled case"
 1156 
 1157 -- Define error=panic, for easier comparison with libraries/pretty.
 1158 error :: String -> a
 1159 error = panic