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