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