Improve documentation (fixes #33).
[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. A Doc represents a /set/ of layouts. A Doc
182 -- with no occurrences of Union or NoDoc represents just one layout.
183 data Doc a
184 = Empty -- ^ An empty span, see 'empty'.
185 | NilAbove (Doc a) -- ^ @text "" $$ x@.
186 | TextBeside !(AnnotDetails a) (Doc a) -- ^ @text s <> x@.
187 | Nest {-# UNPACK #-} !Int (Doc a) -- ^ @nest k x@.
188 | Union (Doc a) (Doc a) -- ^ @ul `union` ur@.
189 | NoDoc -- ^ The empty set of documents.
190 | Beside (Doc a) Bool (Doc a) -- ^ True <=> space between.
191 | Above (Doc a) Bool (Doc a) -- ^ True <=> never overlap.
192 #if __GLASGOW_HASKELL__ >= 701
193 deriving (Generic)
194 #endif
195
196 {-
197 Here are the invariants:
198
199 1) The argument of NilAbove is never Empty. Therefore a NilAbove occupies at
200 least two lines.
201
202 2) The argument of @TextBeside@ is never @Nest@.
203
204 3) The layouts of the two arguments of @Union@ both flatten to the same 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 to
210 the empty set (@NoDoc@).
211
212 6) An empty document is always represented by @Empty@. It can't be hidden
213 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 longer
216 than the first line of any layout in the right argument. (1) ensures that
217 the left argument has a first line. In view of (3), this invariant means
218 that the right argument must have at least two lines.
219
220 Notice the difference between
221 * NoDoc (no documents)
222 * Empty (one empty document; no height and no width)
223 * text "" (a document containing the empty string; one line high, but has no
224 width)
225 -}
226
227
228 -- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside.
229 type RDoc = Doc
230
231 -- | An annotation (side-metadata) attached at a particular point in a @Doc@.
232 -- Allows carrying non-pretty-printed data around in a @Doc@ that is attached
233 -- at particular points in the structure. Once the @Doc@ is render to an output
234 -- type (such as 'String'), we can also retrieve where in the rendered document
235 -- our annotations start and end (see 'Span' and 'renderSpans').
236 data AnnotDetails a = AnnotStart
237 | NoAnnot !TextDetails {-# UNPACK #-} !Int
238 | AnnotEnd a
239 deriving (Show,Eq)
240
241 instance Functor AnnotDetails where
242 fmap _ AnnotStart = AnnotStart
243 fmap _ (NoAnnot d i) = NoAnnot d i
244 fmap f (AnnotEnd a) = AnnotEnd (f a)
245
246 -- NOTE: Annotations are assumed to have zero length; only text has a length.
247 annotSize :: AnnotDetails a -> Int
248 annotSize (NoAnnot _ l) = l
249 annotSize _ = 0
250
251 -- | A TextDetails represents a fragment of text that will be output at some
252 -- point in a @Doc@.
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
880 -- second.
881 first :: Doc a -> Doc a -> Doc a
882 first p q | nonEmptySet p = p -- unused, because (get OneLineMode) is unused
883 | otherwise = q
884
885 nonEmptySet :: Doc a -> Bool
886 nonEmptySet NoDoc = False
887 nonEmptySet (_ `Union` _) = True
888 nonEmptySet Empty = True
889 nonEmptySet (NilAbove _) = True
890 nonEmptySet (TextBeside _ p) = nonEmptySet p
891 nonEmptySet (Nest _ p) = nonEmptySet p
892 nonEmptySet (Above {}) = error "nonEmptySet Above"
893 nonEmptySet (Beside {}) = error "nonEmptySet Beside"
894
895 -- @oneLiner@ returns the one-line members of the given set of @GDoc@s.
896 oneLiner :: Doc a -> Doc a
897 oneLiner NoDoc = NoDoc
898 oneLiner Empty = Empty
899 oneLiner (NilAbove _) = NoDoc
900 oneLiner (TextBeside s p) = textBeside_ s (oneLiner p)
901 oneLiner (Nest k p) = nest_ k (oneLiner p)
902 oneLiner (p `Union` _) = oneLiner p
903 oneLiner (Above {}) = error "oneLiner Above"
904 oneLiner (Beside {}) = error "oneLiner Beside"
905
906
907 -- ---------------------------------------------------------------------------
908 -- Rendering
909
910 -- | A rendering style. Allows us to specify constraints to choose among the
911 -- many different rendering options.
912 data Style
913 = Style { mode :: Mode
914 -- ^ The rendering mode.
915 , lineLength :: Int
916 -- ^ Maximum length of a line, in characters.
917 , ribbonsPerLine :: Float
918 -- ^ Ratio of line length to ribbon length. A ribbon refers to the
919 -- characters on a line /excluding/ indentation. So a 'lineLength'
920 -- of 100, with a 'ribbonsPerLine' of @2.0@ would only allow up to
921 -- 50 characters of ribbon to be displayed on a line, while
922 -- allowing it to be indented up to 50 characters.
923 }
924 #if __GLASGOW_HASKELL__ >= 701
925 deriving (Show, Eq, Generic)
926 #endif
927
928 -- | The default style (@mode=PageMode, lineLength=100, ribbonsPerLine=1.5@).
929 style :: Style
930 style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode }
931
932 -- | Rendering mode.
933 data Mode = PageMode
934 -- ^ Normal rendering ('lineLength' and 'ribbonsPerLine'
935 -- respected').
936 | ZigZagMode
937 -- ^ With zig-zag cuts.
938 | LeftMode
939 -- ^ No indentation, infinitely long lines ('lineLength' ignored),
940 -- but explicit new lines, i.e., @text "one" $$ text "two"@, are
941 -- respected.
942 | OneLineMode
943 -- ^ All on one line, 'lineLength' ignored and explicit new lines
944 -- (@$$@) are turned into spaces.
945 #if __GLASGOW_HASKELL__ >= 701
946 deriving (Show, Eq, Generic)
947 #endif
948
949 -- | Render the @Doc@ to a String using the default @Style@ (see 'style').
950 render :: Doc a -> String
951 render = fullRender (mode style) (lineLength style) (ribbonsPerLine style)
952 txtPrinter ""
953
954 -- | Render the @Doc@ to a String using the given @Style@.
955 renderStyle :: Style -> Doc a -> String
956 renderStyle s = fullRender (mode s) (lineLength s) (ribbonsPerLine s)
957 txtPrinter ""
958
959 -- | Default TextDetails printer.
960 txtPrinter :: TextDetails -> String -> String
961 txtPrinter (Chr c) s = c:s
962 txtPrinter (Str s1) s2 = s1 ++ s2
963 txtPrinter (PStr s1) s2 = s1 ++ s2
964
965 -- | The general rendering interface. Please refer to the @Style@ and @Mode@
966 -- types for a description of rendering mode, line length and ribbons.
967 fullRender :: Mode -- ^ Rendering mode.
968 -> Int -- ^ Line length.
969 -> Float -- ^ Ribbons per line.
970 -> (TextDetails -> a -> a) -- ^ What to do with text.
971 -> a -- ^ What to do at the end.
972 -> Doc b -- ^ The document.
973 -> a -- ^ Result.
974 fullRender m l r txt = fullRenderAnn m l r annTxt
975 where
976 annTxt (NoAnnot s _) = txt s
977 annTxt _ = id
978
979 -- | The general rendering interface, supporting annotations. Please refer to
980 -- the @Style@ and @Mode@ types for a description of rendering mode, line
981 -- length and ribbons.
982 fullRenderAnn :: Mode -- ^ Rendering mode.
983 -> Int -- ^ Line length.
984 -> Float -- ^ Ribbons per line.
985 -> (AnnotDetails b -> a -> a) -- ^ What to do with text.
986 -> a -- ^ What to do at the end.
987 -> Doc b -- ^ The document.
988 -> a -- ^ Result.
989 fullRenderAnn OneLineMode _ _ txt end doc
990 = easyDisplay spaceText (\_ y -> y) txt end (reduceDoc doc)
991 fullRenderAnn LeftMode _ _ txt end doc
992 = easyDisplay nlText first txt end (reduceDoc doc)
993
994 fullRenderAnn m lineLen ribbons txt rest doc
995 = display m lineLen ribbonLen txt rest doc'
996 where
997 doc' = best bestLineLen ribbonLen (reduceDoc doc)
998
999 bestLineLen, ribbonLen :: Int
1000 ribbonLen = round (fromIntegral lineLen / ribbons)
1001 bestLineLen = case m of
1002 ZigZagMode -> maxBound
1003 _ -> lineLen
1004
1005 easyDisplay :: AnnotDetails b
1006 -> (Doc b -> Doc b -> Doc b)
1007 -> (AnnotDetails b -> a -> a)
1008 -> a
1009 -> Doc b
1010 -> a
1011 easyDisplay nlSpaceText choose txt end
1012 = lay
1013 where
1014 lay NoDoc = error "easyDisplay: NoDoc"
1015 lay (Union p q) = lay (choose p q)
1016 lay (Nest _ p) = lay p
1017 lay Empty = end
1018 lay (NilAbove p) = nlSpaceText `txt` lay p
1019 lay (TextBeside s p) = s `txt` lay p
1020 lay (Above {}) = error "easyDisplay Above"
1021 lay (Beside {}) = error "easyDisplay Beside"
1022
1023 display :: Mode -> Int -> Int -> (AnnotDetails b -> a -> a) -> a -> Doc b -> a
1024 display m !page_width !ribbon_width txt end doc
1025 = case page_width - ribbon_width of { gap_width ->
1026 case gap_width `quot` 2 of { shift ->
1027 let
1028 lay k _ | k `seq` False = undefined
1029 lay k (Nest k1 p) = lay (k + k1) p
1030 lay _ Empty = end
1031 lay k (NilAbove p) = nlText `txt` lay k p
1032 lay k (TextBeside s p)
1033 = case m of
1034 ZigZagMode | k >= gap_width
1035 -> nlText `txt` (
1036 NoAnnot (Str (replicate shift '/')) shift `txt` (
1037 nlText `txt`
1038 lay1 (k - shift) s p ))
1039
1040 | k < 0
1041 -> nlText `txt` (
1042 NoAnnot (Str (replicate shift '\\')) shift `txt` (
1043 nlText `txt`
1044 lay1 (k + shift) s p ))
1045
1046 _ -> lay1 k s p
1047
1048 lay _ (Above {}) = error "display lay Above"
1049 lay _ (Beside {}) = error "display lay Beside"
1050 lay _ NoDoc = error "display lay NoDoc"
1051 lay _ (Union {}) = error "display lay Union"
1052
1053 lay1 !k s p = let !r = k + annotSize s
1054 in NoAnnot (Str (indent k)) k `txt` (s `txt` lay2 r p)
1055
1056 lay2 k _ | k `seq` False = undefined
1057 lay2 k (NilAbove p) = nlText `txt` lay k p
1058 lay2 k (TextBeside s p) = s `txt` lay2 (k + annotSize s) p
1059 lay2 k (Nest _ p) = lay2 k p
1060 lay2 _ Empty = end
1061 lay2 _ (Above {}) = error "display lay2 Above"
1062 lay2 _ (Beside {}) = error "display lay2 Beside"
1063 lay2 _ NoDoc = error "display lay2 NoDoc"
1064 lay2 _ (Union {}) = error "display lay2 Union"
1065 in
1066 lay 0 doc
1067 }}
1068
1069
1070
1071 -- Rendering Annotations -------------------------------------------------------
1072
1073 -- | A @Span@ represents the result of an annotation after a @Doc@ has been
1074 -- rendered, capturing where the annotation now starts and ends in the rendered
1075 -- output.
1076 data Span a = Span { spanStart :: !Int
1077 , spanLength :: !Int
1078 , spanAnnotation :: a
1079 } deriving (Show,Eq)
1080
1081 instance Functor Span where
1082 fmap f (Span x y a) = Span x y (f a)
1083
1084
1085 -- State required for generating document spans.
1086 data Spans a = Spans { sOffset :: !Int
1087 -- ^ Current offset from the end of the document.
1088 , sStack :: [Int -> Span a]
1089 -- ^ Currently open spans.
1090 , sSpans :: [Span a]
1091 -- ^ Collected annotation regions.
1092 , sOutput :: String
1093 -- ^ Collected output.
1094 }
1095
1096 -- | Render an annotated @Doc@ to a String and list of annotations (see 'Span')
1097 -- using the default @Style@ (see 'style').
1098 renderSpans :: Doc ann -> (String,[Span ann])
1099 renderSpans = finalize
1100 . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style)
1101 spanPrinter
1102 Spans { sOffset = 0, sStack = [], sSpans = [], sOutput = "" }
1103 where
1104
1105 finalize (Spans size _ spans out) = (out, map adjust spans)
1106 where
1107 adjust s = s { spanStart = size - spanStart s }
1108
1109 mkSpan a end start = Span { spanStart = start
1110 , spanLength = start - end
1111 -- this seems wrong, but remember that it's
1112 -- working backwards at this point
1113 , spanAnnotation = a }
1114
1115 -- the document gets generated in reverse, which is why the starting
1116 -- annotation ends the annotation.
1117 spanPrinter AnnotStart s =
1118 case sStack s of
1119 sp : rest -> s { sSpans = sp (sOffset s) : sSpans s, sStack = rest }
1120 _ -> error "renderSpans: stack underflow"
1121
1122 spanPrinter (AnnotEnd a) s =
1123 s { sStack = mkSpan a (sOffset s) : sStack s }
1124
1125 spanPrinter (NoAnnot td l) s =
1126 case td of
1127 Chr c -> s { sOutput = c : sOutput s, sOffset = sOffset s + l }
1128 Str t -> s { sOutput = t ++ sOutput s, sOffset = sOffset s + l }
1129 PStr t -> s { sOutput = t ++ sOutput s, sOffset = sOffset s + l }
1130
1131
1132 -- | Render out a String, interpreting the annotations as part of the resulting
1133 -- document.
1134 --
1135 -- /IMPORTANT/: the size of the annotation string does NOT figure into the
1136 -- layout of the document, so the document will lay out as though the
1137 -- annotations are not present.
1138 renderDecorated :: (ann -> String) -- ^ Starting an annotation.
1139 -> (ann -> String) -- ^ Ending an annotation.
1140 -> Doc ann -> String
1141 renderDecorated startAnn endAnn =
1142 finalize . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style)
1143 annPrinter
1144 ("", [])
1145 where
1146 annPrinter AnnotStart (rest,stack) =
1147 case stack of
1148 a : as -> (startAnn a ++ rest, as)
1149 _ -> error "renderDecorated: stack underflow"
1150
1151 annPrinter (AnnotEnd a) (rest,stack) =
1152 (endAnn a ++ rest, a : stack)
1153
1154 annPrinter (NoAnnot s _) (rest,stack) =
1155 (txtPrinter s rest, stack)
1156
1157 finalize (str,_) = str
1158
1159
1160 -- | Render a document with annotations, by interpreting the start and end of
1161 -- the annotations, as well as the text details in the context of a monad.
1162 renderDecoratedM :: Monad m
1163 => (ann -> m r) -- ^ Starting an annotation.
1164 -> (ann -> m r) -- ^ Ending an annotation.
1165 -> (String -> m r) -- ^ Text formatting.
1166 -> m r -- ^ Document end.
1167 -> Doc ann -> m r
1168 renderDecoratedM startAnn endAnn txt docEnd =
1169 finalize . fullRenderAnn (mode style) (lineLength style) (ribbonsPerLine style)
1170 annPrinter
1171 (docEnd, [])
1172 where
1173 annPrinter AnnotStart (rest,stack) =
1174 case stack of
1175 a : as -> (startAnn a >> rest, as)
1176 _ -> error "renderDecorated: stack underflow"
1177
1178 annPrinter (AnnotEnd a) (rest,stack) =
1179 (endAnn a >> rest, a : stack)
1180
1181 annPrinter (NoAnnot td _) (rest,stack) =
1182 case td of
1183 Chr c -> (txt [c] >> rest, stack)
1184 Str s -> (txt s >> rest, stack)
1185 PStr s -> (txt s >> rest, stack)
1186
1187 finalize (m,_) = m