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