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