dfc48dd574398aa7caebcfb473be1363c26c4425
[packages/pretty.git] / src / Text / PrettyPrint / Annotated / HughesPJ.hs
1 {-# OPTIONS_HADDOCK not-home #-}
2 {-# LANGUAGE BangPatterns #-}
3 #if __GLASGOW_HASKELL__ >= 701
4 {-# LANGUAGE Safe #-}
5 {-# LANGUAGE DeriveGeneric #-}
6 #endif
7
8 -----------------------------------------------------------------------------
9 -- |
10 -- Module : Text.PrettyPrint.Annotated.HughesPJ
11 -- Copyright : (c) The University of Glasgow 2001
12 -- License : BSD-style (see the file LICENSE)
13 --
14 -- Maintainer : David Terei <code@davidterei.com>
15 -- Stability : stable
16 -- Portability : portable
17 --
18 -- Provides a collection of pretty printer combinators, a set of API's
19 -- that provides a way to easily print out text in a consistent format
20 -- of your choosing.
21 --
22 -- Originally designed by John Hughes's and Simon Peyton Jones's.
23 --
24 -- For more information you can refer to the
25 -- <http://belle.sourceforge.net/doc/hughes95design.pdf original paper> that
26 -- serves as the basis for this libraries design:
27 -- /The Design -- of a Pretty-printing Library/ by John Hughes, in Advanced
28 -- Functional Programming, 1995
29 --
30 -----------------------------------------------------------------------------
31
32 #ifndef TESTING
33 module Text.PrettyPrint.Annotated.HughesPJ (
34
35 -- * The document type
36 Doc, TextDetails(..), AnnotDetails(..),
37
38 -- * Constructing documents
39
40 -- ** Converting values into documents
41 char, text, ptext, sizedText, zeroWidthText,
42 int, integer, float, double, rational,
43
44 -- ** Simple derived documents
45 semi, comma, colon, space, equals,
46 lparen, rparen, lbrack, rbrack, lbrace, rbrace,
47
48 -- ** Wrapping documents in delimiters
49 parens, brackets, braces, quotes, doubleQuotes,
50 maybeParens, maybeBrackets, maybeBraces, maybeQuotes, maybeDoubleQuotes,
51
52 -- ** Combining documents
53 empty,
54 (<>), (<+>), hcat, hsep,
55 ($$), ($+$), vcat,
56 sep, cat,
57 fsep, fcat,
58 nest,
59 hang, punctuate,
60
61 -- ** Annotating documents
62 annotate,
63
64 -- * Predicates on documents
65 isEmpty,
66
67 -- * Utility functions for documents
68 first, reduceDoc,
69
70 -- * Rendering documents
71
72 -- ** Default rendering
73 render,
74
75 -- ** Annotation rendering
76 renderSpans, Span(..),
77 renderDecorated,
78 renderDecoratedM,
79
80 -- ** Rendering with a particular style
81 Style(..),
82 style,
83 renderStyle,
84 Mode(..),
85
86 -- ** General rendering
87 fullRender,
88 fullRenderAnn
89
90 ) where
91 #endif
92
93 import Control.DeepSeq ( NFData(rnf) )
94 import Data.Function ( on )
95 #if __GLASGOW_HASKELL__ < 709
96 import Data.Monoid ( Monoid(mempty, mappend) )
97 #endif
98 import Data.String ( IsString(fromString) )
99
100 import GHC.Generics
101
102 -- ---------------------------------------------------------------------------
103 -- The Doc calculus
104
105 {-
106 Laws for $$
107 ~~~~~~~~~~~
108 <a1> (x $$ y) $$ z = x $$ (y $$ z)
109 <a2> empty $$ x = x
110 <a3> x $$ empty = x
111
112 ...ditto $+$...
113
114 Laws for <>
115 ~~~~~~~~~~~
116 <b1> (x <> y) <> z = x <> (y <> z)
117 <b2> empty <> x = empty
118 <b3> x <> empty = x
119
120 ...ditto <+>...
121
122 Laws for text
123 ~~~~~~~~~~~~~
124 <t1> text s <> text t = text (s++t)
125 <t2> text "" <> x = x, if x non-empty
126
127 ** because of law n6, t2 only holds if x doesn't
128 ** start with `nest'.
129
130
131 Laws for nest
132 ~~~~~~~~~~~~~
133 <n1> nest 0 x = x
134 <n2> nest k (nest k' x) = nest (k+k') x
135 <n3> nest k (x <> y) = nest k x <> nest k y
136 <n4> nest k (x $$ y) = nest k x $$ nest k y
137 <n5> nest k empty = empty
138 <n6> x <> nest k y = x <> y, if x non-empty
139
140 ** Note the side condition on <n6>! It is this that
141 ** makes it OK for empty to be a left unit for <>.
142
143 Miscellaneous
144 ~~~~~~~~~~~~~
145 <m1> (text s <> x) $$ y = text s <> ((text "" <> x) $$
146 nest (-length s) y)
147
148 <m2> (x $$ y) <> z = x $$ (y <> z)
149 if y non-empty
150
151
152 Laws for list versions
153 ~~~~~~~~~~~~~~~~~~~~~~
154 <l1> sep (ps++[empty]++qs) = sep (ps ++ qs)
155 ...ditto hsep, hcat, vcat, fill...
156
157 <l2> nest k (sep ps) = sep (map (nest k) ps)
158 ...ditto hsep, hcat, vcat, fill...
159
160 Laws for oneLiner
161 ~~~~~~~~~~~~~~~~~
162 <o1> oneLiner (nest k p) = nest k (oneLiner p)
163 <o2> oneLiner (x <> y) = oneLiner x <> oneLiner y
164
165 You might think that the following verion of <m1> would
166 be neater:
167
168 <3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$
169 nest (-length s) y)
170
171 But it doesn't work, for if x=empty, we would have
172
173 text s $$ y = text s <> (empty $$ nest (-length s) y)
174 = text s <> nest (-length s) y
175 -}
176
177 -- ---------------------------------------------------------------------------
178 -- Operator fixity
179
180 infixl 6 <>
181 infixl 6 <+>
182 infixl 5 $$, $+$
183
184 -- ---------------------------------------------------------------------------
185 -- The Doc data type
186
187 -- | The abstract type of documents.
188 -- A Doc represents a *set* of layouts. A Doc with
189 -- no occurrences of Union or NoDoc represents just one layout.
190 data Doc a
191 = Empty -- empty
192 | NilAbove (Doc a) -- text "" $$ x
193 | TextBeside !(AnnotDetails a) (Doc a) -- text s <> x
194 | Nest {-# UNPACK #-} !Int (Doc a) -- nest k x
195 | Union (Doc a) (Doc a) -- ul `union` ur
196 | NoDoc -- The empty set of documents
197 | Beside (Doc a) Bool (Doc a) -- True <=> space between
198 | Above (Doc a) Bool (Doc a) -- True <=> never overlap
199 #if __GLASGOW_HASKELL__ >= 701
200 deriving (Generic)
201 #endif
202
203 {-
204 Here are the invariants:
205
206 1) The argument of NilAbove is never Empty. Therefore
207 a NilAbove occupies at least two lines.
208
209 2) The argument of @TextBeside@ is never @Nest@.
210
211 3) The layouts of the two arguments of @Union@ both flatten to the same
212 string.
213
214 4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@.
215
216 5) A @NoDoc@ may only appear on the first line of the left argument of an
217 union. Therefore, the right argument of an union can never be equivalent
218 to the empty set (@NoDoc@).
219
220 6) An empty document is always represented by @Empty@. It can't be
221 hidden inside a @Nest@, or a @Union@ of two @Empty@s.
222
223 7) The first line of every layout in the left argument of @Union@ is
224 longer than the first line of any layout in the right argument.
225 (1) ensures that the left argument has a first line. In view of
226 (3), this invariant means that the right argument must have at
227 least two lines.
228
229 Notice the difference between
230 * NoDoc (no documents)
231 * Empty (one empty document; no height and no width)
232 * text "" (a document containing the empty string;
233 one line high, but has no width)
234 -}
235
236
237 -- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside.
238 type RDoc = Doc
239
240 data AnnotDetails a = AnnotStart
241 | NoAnnot !TextDetails {-# UNPACK #-} !Int
242 | AnnotEnd a
243 deriving (Show,Eq)
244
245 instance Functor AnnotDetails where
246 fmap _ AnnotStart = AnnotStart
247 fmap _ (NoAnnot d i) = NoAnnot d i
248 fmap f (AnnotEnd a) = AnnotEnd (f a)
249
250 -- NOTE: Annotations are assumed to have zero length; only text has a length.
251 annotSize :: AnnotDetails a -> Int
252 annotSize (NoAnnot _ l) = l
253 annotSize _ = 0
254
255 -- | The TextDetails data type
256 --
257 -- A TextDetails represents a fragment of text that will be
258 -- output at some point.
259 data TextDetails = Chr {-# UNPACK #-} !Char -- ^ A single Char fragment
260 | Str String -- ^ A whole String fragment
261 | PStr String -- ^ Used to represent a Fast String fragment
262 -- but now deprecated and identical to the
263 -- Str constructor.
264 #if __GLASGOW_HASKELL__ >= 701
265 deriving (Show, Eq, Generic)
266 #endif
267
268 -- Combining @Doc@ values
269 instance Monoid (Doc a) where
270 mempty = empty
271 mappend = (<>)
272
273 instance IsString (Doc a) where
274 fromString = text
275
276 instance Show (Doc a) where
277 showsPrec _ doc cont = fullRender (mode style) (lineLength style)
278 (ribbonsPerLine style)
279 txtPrinter cont doc
280
281 instance Eq (Doc a) where
282 (==) = (==) `on` render
283
284 instance Functor Doc where
285 fmap _ Empty = Empty
286 fmap f (NilAbove d) = NilAbove (fmap f d)
287 fmap f (TextBeside td d) = TextBeside (fmap f td) (fmap f d)
288 fmap f (Nest k d) = Nest k (fmap f d)
289 fmap f (Union ur ul) = Union (fmap f ur) (fmap f ul)
290 fmap _ NoDoc = NoDoc
291 fmap f (Beside ld s rd) = Beside (fmap f ld) s (fmap f rd)
292 fmap f (Above ud s ld) = Above (fmap f ud) s (fmap f ld)
293
294 instance NFData a => NFData (Doc a) where
295 rnf Empty = ()
296 rnf (NilAbove d) = rnf d
297 rnf (TextBeside td d) = rnf td `seq` rnf d
298 rnf (Nest k d) = rnf k `seq` rnf d
299 rnf (Union ur ul) = rnf ur `seq` rnf ul
300 rnf NoDoc = ()
301 rnf (Beside ld s rd) = rnf ld `seq` rnf s `seq` rnf rd
302 rnf (Above ud s ld) = rnf ud `seq` rnf s `seq` rnf ld
303
304 instance NFData a => NFData (AnnotDetails a) where
305 rnf AnnotStart = ()
306 rnf (NoAnnot d sl) = rnf d `seq` rnf sl
307 rnf (AnnotEnd a) = rnf a
308
309 instance NFData TextDetails where
310 rnf (Chr c) = rnf c
311 rnf (Str str) = rnf str
312 rnf (PStr str) = rnf str
313
314 -- ---------------------------------------------------------------------------
315 -- Values and Predicates on GDocs and TextDetails
316
317 -- | Attach an annotation to a document.
318 annotate :: a -> Doc a -> Doc a
319 annotate a d = TextBeside AnnotStart
320 $ beside (reduceDoc d) False
321 $ TextBeside (AnnotEnd a) Empty
322
323
324 -- | A document of height and width 1, containing a literal character.
325 char :: Char -> Doc a
326 char c = textBeside_ (NoAnnot (Chr c) 1) Empty
327
328 -- | A document of height 1 containing a literal string.
329 -- 'text' satisfies the following laws:
330 --
331 -- * @'text' s '<>' 'text' t = 'text' (s'++'t)@
332 --
333 -- * @'text' \"\" '<>' x = x@, if @x@ non-empty
334 --
335 -- The side condition on the last law is necessary because @'text' \"\"@
336 -- has height 1, while 'empty' has no height.
337 text :: String -> Doc a
338 text s = case length s of {sl -> textBeside_ (NoAnnot (Str s) sl) Empty}
339
340 -- | Same as @text@. Used to be used for Bytestrings.
341 ptext :: String -> Doc a
342 ptext s = case length s of {sl -> textBeside_ (NoAnnot (PStr s) sl) Empty}
343
344 -- | Some text with any width. (@text s = sizedText (length s) s@)
345 sizedText :: Int -> String -> Doc a
346 sizedText l s = textBeside_ (NoAnnot (Str s) l) Empty
347
348 -- | Some text, but without any width. Use for non-printing text
349 -- such as a HTML or Latex tags
350 zeroWidthText :: String -> Doc a
351 zeroWidthText = sizedText 0
352
353 -- | The empty document, with no height and no width.
354 -- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere
355 -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.
356 empty :: Doc a
357 empty = Empty
358
359 -- | Returns 'True' if the document is empty
360 isEmpty :: Doc a -> Bool
361 isEmpty Empty = True
362 isEmpty _ = False
363
364 -- | Produce spacing for indenting the amount specified.
365 --
366 -- an old version inserted tabs being 8 columns apart in the output.
367 indent :: Int -> String
368 indent !n = replicate n ' '
369
370 {-
371 Q: What is the reason for negative indentation (i.e. argument to indent
372 is < 0) ?
373
374 A:
375 This indicates an error in the library client's code.
376 If we compose a <> b, and the first line of b is more indented than some
377 other lines of b, the law <n6> (<> eats nests) may cause the pretty
378 printer to produce an invalid layout:
379
380 doc |0123345
381 ------------------
382 d1 |a...|
383 d2 |...b|
384 |c...|
385
386 d1<>d2 |ab..|
387 c|....|
388
389 Consider a <> b, let `s' be the length of the last line of `a', `k' the
390 indentation of the first line of b, and `k0' the indentation of the
391 left-most line b_i of b.
392
393 The produced layout will have negative indentation if `k - k0 > s', as
394 the first line of b will be put on the (s+1)th column, effectively
395 translating b horizontally by (k-s). Now if the i^th line of b has an
396 indentation k0 < (k-s), it is translated out-of-page, causing
397 `negative indentation'.
398 -}
399
400
401 semi :: Doc a -- ^ A ';' character
402 comma :: Doc a -- ^ A ',' character
403 colon :: Doc a -- ^ A ':' character
404 space :: Doc a -- ^ A space character
405 equals :: Doc a -- ^ A '=' character
406 lparen :: Doc a -- ^ A '(' character
407 rparen :: Doc a -- ^ A ')' character
408 lbrack :: Doc a -- ^ A '[' character
409 rbrack :: Doc a -- ^ A ']' character
410 lbrace :: Doc a -- ^ A '{' character
411 rbrace :: Doc a -- ^ A '}' character
412 semi = char ';'
413 comma = char ','
414 colon = char ':'
415 space = char ' '
416 equals = char '='
417 lparen = char '('
418 rparen = char ')'
419 lbrack = char '['
420 rbrack = char ']'
421 lbrace = char '{'
422 rbrace = char '}'
423
424 spaceText, nlText :: AnnotDetails a
425 spaceText = NoAnnot (Chr ' ') 1
426 nlText = NoAnnot (Chr '\n') 1
427
428 int :: Int -> Doc a -- ^ @int n = text (show n)@
429 integer :: Integer -> Doc a -- ^ @integer n = text (show n)@
430 float :: Float -> Doc a -- ^ @float n = text (show n)@
431 double :: Double -> Doc a -- ^ @double n = text (show n)@
432 rational :: Rational -> Doc a -- ^ @rational n = text (show n)@
433 int n = text (show n)
434 integer n = text (show n)
435 float n = text (show n)
436 double n = text (show n)
437 rational n = text (show n)
438
439 parens :: Doc a -> Doc a -- ^ Wrap document in @(...)@
440 brackets :: Doc a -> Doc a -- ^ Wrap document in @[...]@
441 braces :: Doc a -> Doc a -- ^ Wrap document in @{...}@
442 quotes :: Doc a -> Doc a -- ^ Wrap document in @\'...\'@
443 doubleQuotes :: Doc a -> Doc a -- ^ Wrap document in @\"...\"@
444 quotes p = char '\'' <> p <> char '\''
445 doubleQuotes p = char '"' <> p <> char '"'
446 parens p = char '(' <> p <> char ')'
447 brackets p = char '[' <> p <> char ']'
448 braces p = char '{' <> p <> char '}'
449
450 -- | Apply 'parens' to 'Doc' if boolean is true.
451 maybeParens :: Bool -> Doc a -> Doc a
452 maybeParens False = id
453 maybeParens True = parens
454
455 -- | Apply 'brackets' to 'Doc' if boolean is true.
456 maybeBrackets :: Bool -> Doc a -> Doc a
457 maybeBrackets False = id
458 maybeBrackets True = brackets
459
460 -- | Apply 'braces' to 'Doc' if boolean is true.
461 maybeBraces :: Bool -> Doc a -> Doc a
462 maybeBraces False = id
463 maybeBraces True = braces
464
465 -- | Apply 'quotes' to 'Doc' if boolean is true.
466 maybeQuotes :: Bool -> Doc a -> Doc a
467 maybeQuotes False = id
468 maybeQuotes True = quotes
469
470 -- | Apply 'doubleQuotes' to 'Doc' if boolean is true.
471 maybeDoubleQuotes :: Bool -> Doc a -> Doc a
472 maybeDoubleQuotes False = id
473 maybeDoubleQuotes True = doubleQuotes
474
475 -- ---------------------------------------------------------------------------
476 -- Structural operations on GDocs
477
478 -- | Perform some simplification of a built up @GDoc@.
479 reduceDoc :: Doc a -> RDoc a
480 reduceDoc (Beside p g q) = beside p g (reduceDoc q)
481 reduceDoc (Above p g q) = above p g (reduceDoc q)
482 reduceDoc p = p
483
484 -- | List version of '<>'.
485 hcat :: [Doc a] -> Doc a
486 hcat = snd . reduceHoriz . foldr (\p q -> Beside p False q) empty
487
488 -- | List version of '<+>'.
489 hsep :: [Doc a] -> Doc a
490 hsep = snd . reduceHoriz . foldr (\p q -> Beside p True q) empty
491
492 -- | List version of '$$'.
493 vcat :: [Doc a] -> Doc a
494 vcat = snd . reduceVert . foldr (\p q -> Above p False q) empty
495
496 -- | Nest (or indent) a document by a given number of positions
497 -- (which may also be negative). 'nest' satisfies the laws:
498 --
499 -- * @'nest' 0 x = x@
500 --
501 -- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@
502 --
503 -- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@
504 --
505 -- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@
506 --
507 -- * @'nest' k 'empty' = 'empty'@
508 --
509 -- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty
510 --
511 -- The side condition on the last law is needed because
512 -- 'empty' is a left identity for '<>'.
513 nest :: Int -> Doc a -> Doc a
514 nest k p = mkNest k (reduceDoc p)
515
516 -- | @hang d1 n d2 = sep [d1, nest n d2]@
517 hang :: Doc a -> Int -> Doc a -> Doc a
518 hang d1 n d2 = sep [d1, nest n d2]
519
520 -- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
521 punctuate :: Doc a -> [Doc a] -> [Doc a]
522 punctuate _ [] = []
523 punctuate p (x:xs) = go x xs
524 where go y [] = [y]
525 go y (z:zs) = (y <> p) : go z zs
526
527 -- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
528 mkNest :: Int -> Doc a -> Doc a
529 mkNest k _ | k `seq` False = undefined
530 mkNest k (Nest k1 p) = mkNest (k + k1) p
531 mkNest _ NoDoc = NoDoc
532 mkNest _ Empty = Empty
533 mkNest 0 p = p
534 mkNest k p = nest_ k p
535
536 -- mkUnion checks for an empty document
537 mkUnion :: Doc a -> Doc a -> Doc a
538 mkUnion Empty _ = Empty
539 mkUnion p q = p `union_` q
540
541 data IsEmpty = IsEmpty | NotEmpty
542
543 reduceHoriz :: Doc a -> (IsEmpty, Doc a)
544 reduceHoriz (Beside p g q) = eliminateEmpty Beside (snd (reduceHoriz p)) g (reduceHoriz q)
545 reduceHoriz doc = (NotEmpty, doc)
546
547 reduceVert :: Doc a -> (IsEmpty, Doc a)
548 reduceVert (Above p g q) = eliminateEmpty Above (snd (reduceVert p)) g (reduceVert q)
549 reduceVert doc = (NotEmpty, doc)
550
551 {-# INLINE eliminateEmpty #-}
552 eliminateEmpty ::
553 (Doc a -> Bool -> Doc a -> Doc a) ->
554 Doc a -> Bool -> (IsEmpty, Doc a) -> (IsEmpty, Doc a)
555 eliminateEmpty _ Empty _ q = q
556 eliminateEmpty cons p g q =
557 (NotEmpty,
558 -- We're not empty whether or not q is empty, so for laziness-sake,
559 -- after checking that p isn't empty, we put the NotEmpty result
560 -- outside independent of q. This allows reduceAB to immediately
561 -- return the appropriate constructor (Above or Beside) without
562 -- forcing the entire nested Doc. This allows the foldr in vcat,
563 -- hsep, and hcat to be lazy on its second argument, avoiding a
564 -- stack overflow.
565 case q of
566 (NotEmpty, q') -> cons p g q'
567 (IsEmpty, _) -> p)
568
569 nilAbove_ :: RDoc a -> RDoc a
570 nilAbove_ = NilAbove
571
572 -- Arg of a TextBeside is always an RDoc
573 textBeside_ :: AnnotDetails a -> RDoc a -> RDoc a
574 textBeside_ = TextBeside
575
576 nest_ :: Int -> RDoc a -> RDoc a
577 nest_ = Nest
578
579 union_ :: RDoc a -> RDoc a -> RDoc a
580 union_ = Union
581
582
583 -- ---------------------------------------------------------------------------
584 -- Vertical composition @$$@
585
586 -- | Above, except that if the last line of the first argument stops
587 -- at least one position before the first line of the second begins,
588 -- these two lines are overlapped. For example:
589 --
590 -- > text "hi" $$ nest 5 (text "there")
591 --
592 -- lays out as
593 --
594 -- > hi there
595 --
596 -- rather than
597 --
598 -- > hi
599 -- > there
600 --
601 -- '$$' is associative, with identity 'empty', and also satisfies
602 --
603 -- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.
604 --
605 ($$) :: Doc a -> Doc a -> Doc a
606 p $$ q = above_ p False q
607
608 -- | Above, with no overlapping.
609 -- '$+$' is associative, with identity 'empty'.
610 ($+$) :: Doc a -> Doc a -> Doc a
611 p $+$ q = above_ p True q
612
613 above_ :: Doc a -> Bool -> Doc a -> Doc a
614 above_ p _ Empty = p
615 above_ Empty _ q = q
616 above_ p g q = Above p g q
617
618 above :: Doc a -> Bool -> RDoc a -> RDoc a
619 above (Above p g1 q1) g2 q2 = above p g1 (above q1 g2 q2)
620 above p@(Beside{}) g q = aboveNest (reduceDoc p) g 0 (reduceDoc q)
621 above p g q = aboveNest p g 0 (reduceDoc q)
622
623 -- Specfication: aboveNest p g k q = p $g$ (nest k q)
624 aboveNest :: RDoc a -> Bool -> Int -> RDoc a -> RDoc a
625 aboveNest _ _ k _ | k `seq` False = undefined
626 aboveNest NoDoc _ _ _ = NoDoc
627 aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_`
628 aboveNest p2 g k q
629
630 aboveNest Empty _ k q = mkNest k q
631 aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q)
632 -- p can't be Empty, so no need for mkNest
633
634 aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q)
635 aboveNest (TextBeside s p) g k q = TextBeside s rest
636 where
637 !k1 = k - annotSize s
638 rest = case p of
639 Empty -> nilAboveNest g k1 q
640 _ -> aboveNest p g k1 q
641
642 aboveNest (Above {}) _ _ _ = error "aboveNest Above"
643 aboveNest (Beside {}) _ _ _ = error "aboveNest Beside"
644
645 -- Specification: text s <> nilaboveNest g k q
646 -- = text s <> (text "" $g$ nest k q)
647 nilAboveNest :: Bool -> Int -> RDoc a -> RDoc a
648 nilAboveNest _ k _ | k `seq` False = undefined
649 nilAboveNest _ _ Empty = Empty
650 -- Here's why the "text s <>" is in the spec!
651 nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q
652 nilAboveNest g k q | not g && k > 0 -- No newline if no overlap
653 = textBeside_ (NoAnnot (Str (indent k)) k) q
654 | otherwise -- Put them really above
655 = nilAbove_ (mkNest k q)
656
657
658 -- ---------------------------------------------------------------------------
659 -- Horizontal composition @<>@
660
661 -- We intentionally avoid Data.Monoid.(<>) here due to interactions of
662 -- Data.Monoid.(<>) and (<+>). See
663 -- http://www.haskell.org/pipermail/libraries/2011-November/017066.html
664
665 -- | Beside.
666 -- '<>' is associative, with identity 'empty'.
667 (<>) :: Doc a -> Doc a -> Doc a
668 p <> q = beside_ p False q
669
670 -- | Beside, separated by space, unless one of the arguments is 'empty'.
671 -- '<+>' is associative, with identity 'empty'.
672 (<+>) :: Doc a -> Doc a -> Doc a
673 p <+> q = beside_ p True q
674
675 beside_ :: Doc a -> Bool -> Doc a -> Doc a
676 beside_ p _ Empty = p
677 beside_ Empty _ q = q
678 beside_ p g q = Beside p g q
679
680 -- Specification: beside g p q = p <g> q
681 beside :: Doc a -> Bool -> RDoc a -> RDoc a
682 beside NoDoc _ _ = NoDoc
683 beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q
684 beside Empty _ q = q
685 beside (Nest k p) g q = nest_ k $! beside p g q
686 beside p@(Beside p1 g1 q1) g2 q2
687 | g1 == g2 = beside p1 g1 $! beside q1 g2 q2
688 | otherwise = beside (reduceDoc p) g2 q2
689 beside p@(Above{}) g q = let !d = reduceDoc p in beside d g q
690 beside (NilAbove p) g q = nilAbove_ $! beside p g q
691 beside (TextBeside t p) g q = TextBeside t $! rest
692 where
693 rest = case p of
694 Empty -> nilBeside g q
695 _ -> beside p g q
696
697 -- Specification: text "" <> nilBeside g p
698 -- = text "" <g> p
699 nilBeside :: Bool -> RDoc a -> RDoc a
700 nilBeside _ Empty = Empty -- Hence the text "" in the spec
701 nilBeside g (Nest _ p) = nilBeside g p
702 nilBeside g p | g = textBeside_ spaceText p
703 | otherwise = p
704
705
706 -- ---------------------------------------------------------------------------
707 -- Separate, @sep@
708
709 -- Specification: sep ps = oneLiner (hsep ps)
710 -- `union`
711 -- vcat ps
712
713 -- | Either 'hsep' or 'vcat'.
714 sep :: [Doc a] -> Doc a
715 sep = sepX True -- Separate with spaces
716
717 -- | Either 'hcat' or 'vcat'.
718 cat :: [Doc a] -> Doc a
719 cat = sepX False -- Don't
720
721 sepX :: Bool -> [Doc a] -> Doc a
722 sepX _ [] = empty
723 sepX x (p:ps) = sep1 x (reduceDoc p) 0 ps
724
725
726 -- Specification: sep1 g k ys = sep (x : map (nest k) ys)
727 -- = oneLiner (x <g> nest k (hsep ys))
728 -- `union` x $$ nest k (vcat ys)
729 sep1 :: Bool -> RDoc a -> Int -> [Doc a] -> RDoc a
730 sep1 _ _ k _ | k `seq` False = undefined
731 sep1 _ NoDoc _ _ = NoDoc
732 sep1 g (p `Union` q) k ys = sep1 g p k ys `union_`
733 aboveNest q False k (reduceDoc (vcat ys))
734
735 sep1 g Empty k ys = mkNest k (sepX g ys)
736 sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys)
737
738 sep1 _ (NilAbove p) k ys = nilAbove_
739 (aboveNest p False k (reduceDoc (vcat ys)))
740 sep1 g (TextBeside s p) k ys = textBeside_ s (sepNB g p (k - annotSize s) ys)
741 sep1 _ (Above {}) _ _ = error "sep1 Above"
742 sep1 _ (Beside {}) _ _ = error "sep1 Beside"
743
744 -- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
745 -- Called when we have already found some text in the first item
746 -- We have to eat up nests
747 sepNB :: Bool -> Doc a -> Int -> [Doc a] -> Doc a
748 sepNB g (Nest _ p) k ys
749 = sepNB g p k ys -- Never triggered, because of invariant (2)
750 sepNB g Empty k ys
751 = oneLiner (nilBeside g (reduceDoc rest)) `mkUnion`
752 -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
753 nilAboveNest False k (reduceDoc (vcat ys))
754 where
755 rest | g = hsep ys
756 | otherwise = hcat ys
757 sepNB g p k ys
758 = sep1 g p k ys
759
760
761 -- ---------------------------------------------------------------------------
762 -- @fill@
763
764 -- | \"Paragraph fill\" version of 'cat'.
765 fcat :: [Doc a] -> Doc a
766 fcat = fill False
767
768 -- | \"Paragraph fill\" version of 'sep'.
769 fsep :: [Doc a] -> Doc a
770 fsep = fill True
771
772 -- Specification:
773 --
774 -- fill g docs = fillIndent 0 docs
775 --
776 -- fillIndent k [] = []
777 -- fillIndent k [p] = p
778 -- fillIndent k (p1:p2:ps) =
779 -- oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0)
780 -- (remove_nests (oneLiner p2) : ps)
781 -- `Union`
782 -- (p1 $*$ nest (-k) (fillIndent 0 ps))
783 --
784 -- $*$ is defined for layouts (not Docs) as
785 -- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2
786 -- | otherwise = layout1 $+$ layout2
787
788 fill :: Bool -> [Doc a] -> RDoc a
789 fill _ [] = empty
790 fill g (p:ps) = fill1 g (reduceDoc p) 0 ps
791
792 fill1 :: Bool -> RDoc a -> Int -> [Doc a] -> Doc a
793 fill1 _ _ k _ | k `seq` False = undefined
794 fill1 _ NoDoc _ _ = NoDoc
795 fill1 g (p `Union` q) k ys = fill1 g p k ys `union_`
796 aboveNest q False k (fill g ys)
797 fill1 g Empty k ys = mkNest k (fill g ys)
798 fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys)
799 fill1 g (NilAbove p) k ys = nilAbove_ (aboveNest p False k (fill g ys))
800 fill1 g (TextBeside s p) k ys = textBeside_ s (fillNB g p (k - annotSize s) ys)
801 fill1 _ (Above {}) _ _ = error "fill1 Above"
802 fill1 _ (Beside {}) _ _ = error "fill1 Beside"
803
804 fillNB :: Bool -> Doc a -> Int -> [Doc a] -> Doc a
805 fillNB _ _ k _ | k `seq` False = undefined
806 fillNB g (Nest _ p) k ys = fillNB g p k ys
807 -- Never triggered, because of invariant (2)
808 fillNB _ Empty _ [] = Empty
809 fillNB g Empty k (Empty:ys) = fillNB g Empty k ys
810 fillNB g Empty k (y:ys) = fillNBE g k y ys
811 fillNB g p k ys = fill1 g p k ys
812
813
814 fillNBE :: Bool -> Int -> Doc a -> [Doc a] -> Doc a
815 fillNBE g k y ys
816 = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k' ys)
817 -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
818 `mkUnion` nilAboveNest False k (fill g (y:ys))
819 where k' = if g then k - 1 else k
820
821 elideNest :: Doc a -> Doc a
822 elideNest (Nest _ d) = d
823 elideNest d = d
824
825
826 -- ---------------------------------------------------------------------------
827 -- Selecting the best layout
828
829 best :: Int -- Line length
830 -> Int -- Ribbon length
831 -> RDoc a
832 -> RDoc a -- No unions in here!
833 best w0 r = get w0
834 where
835 get w _ | w == 0 && False = undefined
836 get _ Empty = Empty
837 get _ NoDoc = NoDoc
838 get w (NilAbove p) = nilAbove_ (get w p)
839 get w (TextBeside s p) = textBeside_ s (get1 w (annotSize s) p)
840 get w (Nest k p) = nest_ k (get (w - k) p)
841 get w (p `Union` q) = nicest w r (get w p) (get w q)
842 get _ (Above {}) = error "best get Above"
843 get _ (Beside {}) = error "best get Beside"
844
845 get1 w _ _ | w == 0 && False = undefined
846 get1 _ _ Empty = Empty
847 get1 _ _ NoDoc = NoDoc
848 get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p)
849 get1 w sl (TextBeside s p) = textBeside_ s (get1 w (sl + annotSize s) p)
850 get1 w sl (Nest _ p) = get1 w sl p
851 get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p)
852 (get1 w sl q)
853 get1 _ _ (Above {}) = error "best get1 Above"
854 get1 _ _ (Beside {}) = error "best get1 Beside"
855
856 nicest :: Int -> Int -> Doc a -> Doc a -> Doc a
857 nicest !w !r = nicest1 w r 0
858
859 nicest1 :: Int -> Int -> Int -> Doc a -> Doc a -> Doc a
860 nicest1 !w !r !sl p q | fits ((w `min` r) - sl) p = p
861 | otherwise = q
862
863 fits :: Int -- Space available
864 -> Doc a
865 -> Bool -- True if *first line* of Doc fits in space available
866 fits n _ | n < 0 = False
867 fits _ NoDoc = False
868 fits _ Empty = True
869 fits _ (NilAbove _) = True
870 fits n (TextBeside s p) = fits (n - annotSize s) p
871 fits _ (Above {}) = error "fits Above"
872 fits _ (Beside {}) = error "fits Beside"
873 fits _ (Union {}) = error "fits Union"
874 fits _ (Nest {}) = error "fits Nest"
875
876 -- | @first@ returns its first argument if it is non-empty, otherwise its second.
877 first :: Doc a -> Doc a -> Doc a
878 first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused
879 | otherwise = q
880
881 nonEmptySet :: Doc a -> Bool
882 nonEmptySet NoDoc = False
883 nonEmptySet (_ `Union` _) = True
884 nonEmptySet Empty = True
885 nonEmptySet (NilAbove _) = True
886 nonEmptySet (TextBeside _ p) = nonEmptySet p
887 nonEmptySet (Nest _ p) = nonEmptySet p
888 nonEmptySet (Above {}) = error "nonEmptySet Above"
889 nonEmptySet (Beside {}) = error "nonEmptySet Beside"
890
891 -- @oneLiner@ returns the one-line members of the given set of @GDoc@s.
892 oneLiner :: Doc a -> Doc a
893 oneLiner NoDoc = NoDoc
894 oneLiner Empty = Empty
895 oneLiner (NilAbove _) = NoDoc
896 oneLiner (TextBeside s p) = textBeside_ s (oneLiner p)
897 oneLiner (Nest k p) = nest_ k (oneLiner p)
898 oneLiner (p `Union` _) = oneLiner p
899 oneLiner (Above {}) = error "oneLiner Above"
900 oneLiner (Beside {}) = error "oneLiner Beside"
901
902
903 -- ---------------------------------------------------------------------------
904 -- Rendering
905
906 -- | A rendering style.
907 data Style
908 = Style { mode :: Mode -- ^ The rendering mode
909 , lineLength :: Int -- ^ Length of line, in chars
910 , ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length
911 }
912 #if __GLASGOW_HASKELL__ >= 701
913 deriving (Show, Eq, Generic)
914 #endif
915
916 -- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).
917 style :: Style
918 style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }
919
920 -- | Rendering mode.
921 data Mode = PageMode -- ^ Normal
922 | ZigZagMode -- ^ With zig-zag cuts
923 | LeftMode -- ^ No indentation, infinitely long lines
924 | OneLineMode -- ^ All on one line
925 #if __GLASGOW_HASKELL__ >= 701
926 deriving (Show, Eq, Generic)
927 #endif
928
929 -- | Render the @Doc@ to a String using the default @Style@.
930 render :: Doc a -> String
931 render = fullRender (mode style) (lineLength style) (ribbonsPerLine style)
932 txtPrinter ""
933
934 -- | Render the @Doc@ to a String using the given @Style@.
935 renderStyle :: Style -> Doc a -> String
936 renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)
937 txtPrinter ""
938
939 -- | Default TextDetails printer
940 txtPrinter :: TextDetails -> String -> String
941 txtPrinter (Chr c) s = c:s
942 txtPrinter (Str s1) s2 = s1 ++ s2
943 txtPrinter (PStr s1) s2 = s1 ++ s2
944
945 -- | The general rendering interface.
946 fullRender :: Mode -- ^ Rendering mode
947 -> Int -- ^ Line length
948 -> Float -- ^ Ribbons per line
949 -> (TextDetails -> a -> a) -- ^ What to do with text
950 -> a -- ^ What to do at the end
951 -> Doc b -- ^ The document
952 -> a -- ^ Result
953 fullRender m l r txt = fullRenderAnn m l r annTxt
954 where
955 annTxt (NoAnnot s _) = txt s
956 annTxt _ = id
957
958 fullRenderAnn :: Mode -- ^ Rendering mode
959 -> Int -- ^ Line length
960 -> Float -- ^ Ribbons per line
961 -> (AnnotDetails b -> a -> a) -- ^ What to do with text
962 -> a -- ^ What to do at the end
963 -> Doc b -- ^ The document
964 -> a -- ^ Result
965 fullRenderAnn OneLineMode _ _ txt end doc
966 = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc)
967 fullRenderAnn LeftMode _ _ txt end doc
968 = easyDisplay nlText first txt end (reduceDoc doc)
969
970 fullRenderAnn m lineLen ribbons txt rest doc
971 = display m lineLen ribbonLen txt rest doc'
972 where
973 doc' = best bestLineLen ribbonLen (reduceDoc doc)
974
975 bestLineLen, ribbonLen :: Int
976 ribbonLen = round (fromIntegral lineLen / ribbons)
977 bestLineLen = case m of
978 ZigZagMode -> maxBound
979 _ -> lineLen
980
981 easyDisplay :: AnnotDetails b
982 -> (Doc b -> Doc b -> Doc b)
983 -> (AnnotDetails b -> a -> a)
984 -> a
985 -> Doc b
986 -> a
987 easyDisplay nlSpaceText choose txt end
988 = lay
989 where
990 lay NoDoc = error "easyDisplay: NoDoc"
991 lay (Union p q) = lay (choose p q)
992 lay (Nest _ p) = lay p
993 lay Empty = end
994 lay (NilAbove p) = nlSpaceText `txt` lay p
995 lay (TextBeside s p) = s `txt` lay p
996 lay (Above {}) = error "easyDisplay Above"
997 lay (Beside {}) = error "easyDisplay Beside"
998
999 display :: Mode -> Int -> Int -> (AnnotDetails b -> a -> a) -> a -> Doc b -> a
1000 display m !page_width !ribbon_width txt end doc
1001 = case page_width - ribbon_width of { gap_width ->
1002 case gap_width `quot` 2 of { shift ->
1003 let
1004 lay k _ | k `seq` False = undefined
1005 lay k (Nest k1 p) = lay (k + k1) p
1006 lay _ Empty = end
1007 lay k (NilAbove p) = nlText `txt` lay k p
1008 lay k (TextBeside s p)
1009 = case m of
1010 ZigZagMode | k >= gap_width
1011 -> nlText `txt` (
1012 NoAnnot (Str (replicate shift '/')) shift `txt` (
1013 nlText `txt`
1014 lay1 (k - shift) s p ))
1015
1016 | k < 0
1017 -> nlText `txt` (
1018 NoAnnot (Str (replicate shift '\\')) shift `txt` (
1019 nlText `txt`
1020 lay1 (k + shift) s p ))
1021
1022 _ -> lay1 k s p
1023
1024 lay _ (Above {}) = error "display lay Above"
1025 lay _ (Beside {}) = error "display lay Beside"
1026 lay _ NoDoc = error "display lay NoDoc"
1027 lay _ (Union {}) = error "display lay Union"
1028
1029 lay1 !k s p = let !r = k + annotSize s
1030 in NoAnnot (Str (indent k)) k `txt` (s `txt` lay2 r p)
1031
1032 lay2 k _ | k `seq` False = undefined
1033 lay2 k (NilAbove p) = nlText `txt` lay k p
1034 lay2 k (TextBeside s p) = s `txt` lay2 (k + annotSize s) p
1035 lay2 k (Nest _ p) = lay2 k p
1036 lay2 _ Empty = end
1037 lay2 _ (Above {}) = error "display lay2 Above"
1038 lay2 _ (Beside {}) = error "display lay2 Beside"
1039 lay2 _ NoDoc = error "display lay2 NoDoc"
1040 lay2 _ (Union {}) = error "display lay2 Union"
1041 in
1042 lay 0 doc
1043 }}
1044
1045
1046
1047 -- Rendering Annotations -------------------------------------------------------
1048
1049 data Span a = Span { spanStart
1050 , spanLength :: !Int
1051 , spanAnnotation :: a
1052 } deriving (Show,Eq)
1053
1054 instance Functor Span where
1055 fmap f (Span x y a) = Span x y (f a)
1056
1057
1058 -- State required for generating document spans.
1059 data Spans a = Spans { sOffset :: !Int
1060 -- ^ Current offset from the end of the document
1061 , sStack :: [Int -> Span a]
1062 -- ^ Currently open spans
1063 , sSpans :: [Span a]
1064 -- ^ Collected annotation regions
1065 , sOutput :: String
1066 -- ^ Collected output
1067 }
1068
1069 renderSpans :: Doc ann -> (String,[Span ann])
1070 renderSpans = finalize
1071 . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style)
1072 spanPrinter
1073 Spans { sOffset = 0, sStack = [], sSpans = [], sOutput = "" }
1074 where
1075
1076 finalize (Spans size _ spans out) = (out, map adjust spans)
1077 where
1078 adjust s = s { spanStart = size - spanStart s }
1079
1080 mkSpan a end start = Span { spanStart = start
1081 , spanLength = start - end
1082 -- this seems wrong, but remember that it's
1083 -- working backwards at this point
1084 , spanAnnotation = a }
1085
1086 -- the document gets generated in reverse, which is why the starting
1087 -- annotation ends the annotation.
1088 spanPrinter AnnotStart s =
1089 case sStack s of
1090 sp : rest -> s { sSpans = sp (sOffset s) : sSpans s, sStack = rest }
1091 _ -> error "renderSpans: stack underflow"
1092
1093 spanPrinter (AnnotEnd a) s =
1094 s { sStack = mkSpan a (sOffset s) : sStack s }
1095
1096 spanPrinter (NoAnnot td l) s =
1097 case td of
1098 Chr c -> s { sOutput = c : sOutput s, sOffset = sOffset s + l }
1099 Str t -> s { sOutput = t ++ sOutput s, sOffset = sOffset s + l }
1100 PStr t -> s { sOutput = t ++ sOutput s, sOffset = sOffset s + l }
1101
1102
1103 -- | Render out a String, interpreting the annotations as part of the resulting
1104 -- document.
1105 --
1106 -- IMPORTANT: the size of the annotation string does NOT figure into the layout
1107 -- of the document, so the document will lay out as though the annotations are
1108 -- not present.
1109 renderDecorated :: (ann -> String) -- ^ Starting an annotation
1110 -> (ann -> String) -- ^ Ending an annotation
1111 -> Doc ann -> String
1112 renderDecorated startAnn endAnn =
1113 finalize . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style)
1114 annPrinter
1115 ("", [])
1116 where
1117 annPrinter AnnotStart (rest,stack) =
1118 case stack of
1119 a : as -> (startAnn a ++ rest, as)
1120 _ -> error "renderDecorated: stack underflow"
1121
1122 annPrinter (AnnotEnd a) (rest,stack) =
1123 (endAnn a ++ rest, a : stack)
1124
1125 annPrinter (NoAnnot s _) (rest,stack) =
1126 (txtPrinter s rest, stack)
1127
1128 finalize (str,_) = str
1129
1130
1131 -- | Render a document with annotations, by interpreting the start and end of
1132 -- the annotations, as well as the text details in the context of a monad.
1133 renderDecoratedM :: Monad m
1134 => (ann -> m r) -- ^ Starting an annotation
1135 -> (ann -> m r) -- ^ Ending an annotation
1136 -> (String -> m r) -- ^ Text formatting
1137 -> m r -- ^ Document end
1138 -> Doc ann -> m r
1139 renderDecoratedM startAnn endAnn txt docEnd =
1140 finalize . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style)
1141 annPrinter
1142 (docEnd, [])
1143 where
1144 annPrinter AnnotStart (rest,stack) =
1145 case stack of
1146 a : as -> (startAnn a >> rest, as)
1147 _ -> error "renderDecorated: stack underflow"
1148
1149 annPrinter (AnnotEnd a) (rest,stack) =
1150 (endAnn a >> rest, a : stack)
1151
1152 annPrinter (NoAnnot td _) (rest,stack) =
1153 case td of
1154 Chr c -> (txt [c] >> rest, stack)
1155 Str s -> (txt s >> rest, stack)
1156 PStr s -> (txt s >> rest, stack)
1157
1158 finalize (m,_) = m