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