]> Git — Sourcephile - comptalang.git/blob - lib/Hcompta/Lib/Leijen.hs
Déplace hcompta-calculus vers lol-calculus et lol-typing
[comptalang.git] / lib / Hcompta / Lib / Leijen.hs
1 {-# LANGUAGE FlexibleInstances #-}
2 {-# LANGUAGE MultiParamTypeClasses #-}
3 {-# LANGUAGE Rank2Types #-}
4 -----------------------------------------------------------------------------
5 -- |
6 -- Module : Hcompta.Lib.Leijen
7 -- Copyright : Julien Moutinho <julm+hcompta@autogeree.net> (c) 2015,
8 -- Ivan Lazar Miljenovic <Ivan.Miljenovic@gmail.com> (c) 2010,
9 -- Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan
10 -- License : BSD-style
11 --
12 -- Stability : provisional
13 -- Portability : portable
14 --
15 -- This module is a merge between /wl-pprint-text/ and /ansi-wl-pprint/ packages
16 -- to use 'Text' values rather than 'String's and ANSI formatting.
17 --
18 -- Pretty print module based on Philip Wadler's \"prettier printer\"
19 --
20 -- @
21 -- \"A prettier printer\"
22 -- <http://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf>
23 -- @
24 --
25 -- PPrint is an implementation of the pretty printing combinators
26 -- described by Philip Wadler (1997). In their bare essence, the
27 -- combinators of Wadler are not expressive enough to describe some
28 -- commonly occurring layouts. The PPrint library adds new primitives
29 -- to describe these layouts and works well in practice.
30 --
31 -- The library is based on a single way to concatenate documents,
32 -- which is associative and has both a left and right unit. This
33 -- simple design leads to an efficient and short implementation. The
34 -- simplicity is reflected in the predictable behaviour of the
35 -- combinators which make them easy to use in practice.
36 --
37 -- A thorough description of the primitive combinators and their
38 -- implementation can be found in Philip Wadler's paper
39 -- (1997). Additions and the main differences with his original paper
40 -- are:
41 --
42 -- * The nil document is called empty.
43 --
44 -- * The above combinator is called '<$>'. The operator '</>' is used
45 -- for soft line breaks.
46 --
47 -- * There are three new primitives: 'align', 'fill' and
48 -- 'fillBreak'. These are very useful in practice.
49 --
50 -- * Lots of other useful combinators, like 'fillSep' and 'list'.
51 --
52 -- * There are two renderers, 'renderPretty' for pretty printing and
53 -- 'renderCompact' for compact output. The pretty printing algorithm
54 -- also uses a ribbon-width now for even prettier output.
55 --
56 -- * There are two displayers, 'displayT' for 'Text' values and 'displayIO'
57 -- for file based output.
58 --
59 -- * There is a 'Pretty' class.
60 --
61 -- * The implementation uses optimised representations and strictness
62 -- annotations.
63 --
64 -- Ways that this library differs from /wl-pprint/ (apart from using
65 -- 'Text' rather than 'String'):
66 --
67 -- * Smarter treatment of 'empty' sub-documents (partially copied over
68 -- from the /pretty/ library).
69 -----------------------------------------------------------
70 module Hcompta.Lib.Leijen (
71 -- * Documents
72 Doc,
73
74 -- * Basic combinators
75 empty, char, text, strict_text, (<>), nest, line, linebreak, group, softline,
76 softbreak, spacebreak, renderSmart,
77 -- flatAlt
78
79 -- * Tests
80 is_empty,
81 if_color,
82
83 -- * Alignment
84 --
85 -- | The combinators in this section can not be described by Wadler's
86 -- original combinators. They align their output relative to the
87 -- current output position - in contrast to @nest@ which always
88 -- aligns to the current nesting level. This deprives these
89 -- combinators from being \`optimal\'. In practice however they
90 -- prove to be very useful. The combinators in this section should
91 -- be used with care, since they are more expensive than the other
92 -- combinators. For example, @align@ shouldn't be used to pretty
93 -- print all top-level declarations of a language, but using @hang@
94 -- for let expressions is fine.
95 align, hang, indent, encloseSep, list, tupled, semiBraces,
96
97 -- * Operators
98 (<+>), (<++>), (<$>), (</>), (<$$>), (<//>),
99
100 -- * List combinators
101 hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate, intercalate,
102
103 -- * Fillers
104 fill, fillBreak,
105
106 -- * Bracketing combinators
107 enclose, squotes, dquotes, parens, angles, braces, brackets,
108
109 -- * Character documents
110 lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket,
111 squote, dquote, semi, colon, comma, space, dot, backslash, equals,
112
113 -- * Colorisation combinators
114 black, red, green, yellow, blue, magenta, cyan, white,
115 dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite,
116 onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite,
117 ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite,
118
119 -- * Emboldening combinators
120 bold, debold,
121
122 -- * Underlining combinators
123 underline, deunderline,
124
125 -- * Removing formatting
126 plain,
127
128 -- * Primitive type documents
129 string, int, integer, float, double, rational, bool,
130
131 -- * Position-based combinators
132 column, nesting, width,
133
134 -- * Pretty class
135 Pretty(..),
136
137 -- * Rendering
138 SimpleDoc(..), renderPretty, renderCompact, renderOneLine,
139 displayB, displayT, displayIO, putDoc, hPutDoc,
140 ToDoc(..),
141 Leijen_of_forall_param(..)
142 ) where
143
144 import Data.Char
145 import qualified Data.Foldable (Foldable(..))
146 import Data.Int (Int64)
147 import Data.Bool hiding (bool)
148 import Data.Functor (Functor(..))
149 import Data.Foldable (foldr1)
150 import Data.Maybe (Maybe(..), catMaybes)
151 import Data.Monoid (Monoid(..), (<>))
152 import Data.String (IsString (..))
153 import qualified Data.Text (Text)
154 import Data.Text.Lazy (Text)
155 import qualified Data.Text.Lazy as T
156 import Data.Text.Lazy.Builder (Builder)
157 import qualified Data.Text.Lazy.Builder as B
158 import qualified Data.Text.Lazy.IO as T
159 import Data.Tuple (uncurry)
160 import Prelude ( Eq(..), Show(..), (/=), zipWith, repeat, (.), Int
161 , Float, Double, Rational, Integer, id
162 , ($), (<), (>), (-), (<=), (>=), fromIntegral, min
163 , max, round, Num(..), seq, IO, Monad(..) )
164 import System.IO (Handle, hPutChar, stdout)
165 import System.Console.ANSI ( Color(..), ColorIntensity(..)
166 , ConsoleIntensity(..), ConsoleLayer(..)
167 , hSetSGR, setSGRCode, SGR(..), Underlining(..) )
168 {-# ANN module "HLint: ignore Eta reduce" #-}
169
170
171 infixr 5 </>,<//>,<$>,<$$>
172 infixr 6 <+>,<++>
173
174
175 -----------------------------------------------------------
176 -- list, tupled and semiBraces pretty print a list of
177 -- documents either horizontally or vertically aligned.
178 -----------------------------------------------------------
179
180
181 -- | The document @(list xs)@ comma separates the documents @xs@ and
182 -- encloses them in square brackets. The documents are rendered
183 -- horizontally if that fits the page. Otherwise they are aligned
184 -- vertically. All comma separators are put in front of the
185 -- elements.
186 list :: [Doc] -> Doc
187 list = encloseSep lbracket rbracket comma
188
189 -- | The document @(tupled xs)@ comma separates the documents @xs@ and
190 -- encloses them in parenthesis. The documents are rendered
191 -- horizontally if that fits the page. Otherwise they are aligned
192 -- vertically. All comma separators are put in front of the
193 -- elements.
194 tupled :: [Doc] -> Doc
195 tupled = encloseSep lparen rparen comma
196
197 -- | The document @(semiBraces xs)@ separates the documents @xs@ with
198 -- semi colons and encloses them in braces. The documents are
199 -- rendered horizontally if that fits the page. Otherwise they are
200 -- aligned vertically. All semi colons are put in front of the
201 -- elements.
202 semiBraces :: [Doc] -> Doc
203 semiBraces = encloseSep lbrace rbrace semi
204
205 -- | The document @(encloseSep l r sep xs)@ concatenates the documents
206 -- @xs@ separated by @sep@ and encloses the resulting document by
207 -- @l@ and @r@. The documents are rendered horizontally if that fits
208 -- the page. Otherwise they are aligned vertically. All separators
209 -- are put in front of the elements. For example, the combinator
210 -- 'list' can be defined with @encloseSep@:
211 --
212 -- > list xs = encloseSep lbracket rbracket comma xs
213 -- > test = text "list" <+> (list (map int [10,200,3000]))
214 --
215 -- Which is laid out with a page width of 20 as:
216 --
217 -- @
218 -- list [10,200,3000]
219 -- @
220 --
221 -- But when the page width is 15, it is laid out as:
222 --
223 -- @
224 -- list [10
225 -- ,200
226 -- ,3000]
227 -- @
228 encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc
229 encloseSep left right sp ds
230 = case ds of
231 [] -> left <> right
232 [d] -> left <> d <> right
233 _ -> align (cat (zipWith (<>) (left : repeat sp) ds) <> right)
234
235 -----------------------------------------------------------
236 -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]
237 -----------------------------------------------------------
238
239
240 -- | @(punctuate p xs)@ concatenates all documents in @xs@ with
241 -- document @p@ except for the last document.
242 --
243 -- > someText = map text ["words","in","a","tuple"]
244 -- > test = parens (align (cat (punctuate comma someText)))
245 --
246 -- This is laid out on a page width of 20 as:
247 --
248 -- @
249 -- (words,in,a,tuple)
250 -- @
251 --
252 -- But when the page width is 15, it is laid out as:
253 --
254 -- @
255 -- (words,
256 -- in,
257 -- a,
258 -- tuple)
259 -- @
260 --
261 -- (If you want put the commas in front of their elements instead of
262 -- at the end, you should use 'tupled' or, in general, 'encloseSep'.)
263 punctuate :: Doc -> [Doc] -> [Doc]
264 punctuate _ [] = []
265 punctuate _ [d] = [d]
266 punctuate p (d:ds) = (d <> p) : punctuate p ds
267
268
269 -----------------------------------------------------------
270 -- high-level combinators
271 -----------------------------------------------------------
272
273
274 -- | The document @(sep xs)@ concatenates all documents @xs@ either
275 -- horizontally with @(\<+\>)@, if it fits the page, or vertically
276 -- with @(\<$\>)@.
277 --
278 -- > sep xs = group (vsep xs)
279 sep :: [Doc] -> Doc
280 sep = group . vsep
281
282 -- | The document @(fillSep xs)@ concatenates documents @xs@
283 -- horizontally with @(\<+\>)@ as long as its fits the page, then
284 -- inserts a @line@ and continues doing that for all documents in
285 -- @xs@.
286 --
287 -- > fillSep xs = foldr (</>) empty xs
288 fillSep :: [Doc] -> Doc
289 fillSep = fold (</>)
290
291 -- | The document @(hsep xs)@ concatenates all documents @xs@
292 -- horizontally with @(\<+\>)@.
293 hsep :: [Doc] -> Doc
294 hsep = fold (<+>)
295
296 -- | The document @(vsep xs)@ concatenates all documents @xs@
297 -- vertically with @(\<$\>)@. If a 'group' undoes the line breaks
298 -- inserted by @vsep@, all documents are separated with a space.
299 --
300 -- > someText = map text (words ("text to lay out"))
301 -- >
302 -- > test = text "some" <+> vsep someText
303 --
304 -- This is laid out as:
305 --
306 -- @
307 -- some text
308 -- to
309 -- lay
310 -- out
311 -- @
312 --
313 -- The 'align' combinator can be used to align the documents under
314 -- their first element
315 --
316 -- > test = text "some" <+> align (vsep someText)
317 --
318 -- Which is printed as:
319 --
320 -- @
321 -- some text
322 -- to
323 -- lay
324 -- out
325 -- @
326 vsep :: [Doc] -> Doc
327 vsep = fold (<$>)
328
329 -- | The document @(cat xs)@ concatenates all documents @xs@ either
330 -- horizontally with @(\<\>)@, if it fits the page, or vertically
331 -- with @(\<$$\>)@.
332 --
333 -- > cat xs = group (vcat xs)
334 cat :: [Doc] -> Doc
335 cat = group . vcat
336
337 -- | The document @(fillCat xs)@ concatenates documents @xs@
338 -- horizontally with @(\<\>)@ as long as its fits the page, then
339 -- inserts a @linebreak@ and continues doing that for all documents
340 -- in @xs@.
341 --
342 -- > fillCat xs = foldr (<//>) empty xs
343 fillCat :: [Doc] -> Doc
344 fillCat = fold (<//>)
345
346 -- | The document @(hcat xs)@ concatenates all documents @xs@
347 -- horizontally with @(\<\>)@.
348 hcat :: [Doc] -> Doc
349 hcat = fold (<>)
350
351 -- | The document @(vcat xs)@ concatenates all documents @xs@
352 -- vertically with @(\<$$\>)@. If a 'group' undoes the line breaks
353 -- inserted by @vcat@, all documents are directly concatenated.
354 vcat :: [Doc] -> Doc
355 vcat = fold (<$$>)
356
357 fold :: (Doc -> Doc -> Doc) -> [Doc] -> Doc
358 fold _ [] = empty
359 fold f ds = foldr1 f ds
360
361 -- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with
362 -- a 'space' in between. (infixr 6)
363 (<+>) :: Doc -> Doc -> Doc
364 Empty <+> y = y
365 x <+> Empty = x
366 x <+> y = x <> space <> y
367
368 -- | The document @(x \<++\> y)@ concatenates document @x@ and @y@ with
369 -- a 'spacebreak' in between. (infixr 6)
370 (<++>) :: Doc -> Doc -> Doc
371 Empty <++> y = y
372 x <++> Empty = x
373 x <++> y = x <> spacebreak <> y
374
375
376 -- | The document @(x \<\/\> y)@ concatenates document @x@ and @y@
377 -- with a 'softline' in between. This effectively puts @x@ and @y@
378 -- either next to each other (with a @space@ in between) or
379 -- underneath each other. (infixr 5)
380 (</>) :: Doc -> Doc -> Doc
381 (</>) = splitWithBreak False
382
383 -- | The document @(x \<\/\/\> y)@ concatenates document @x@ and @y@
384 -- with a 'softbreak' in between. This effectively puts @x@ and @y@
385 -- either right next to each other or underneath each other. (infixr
386 -- 5)
387 (<//>) :: Doc -> Doc -> Doc
388 (<//>) = splitWithBreak True
389
390 splitWithBreak :: Bool -> Doc -> Doc -> Doc
391 splitWithBreak _ Empty b = b
392 splitWithBreak _ a Empty = a
393 splitWithBreak f a b = a <> group (Line f) <> b
394
395 -- | The document @(x \<$\> y)@ concatenates document @x@ and @y@ with
396 -- a 'line' in between. (infixr 5)
397 (<$>) :: Doc -> Doc -> Doc
398 (<$>) = splitWithLine False
399
400 -- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@
401 -- with a 'linebreak' in between. (infixr 5)
402 (<$$>) :: Doc -> Doc -> Doc
403 (<$$>) = splitWithLine True
404
405 splitWithLine :: Bool -> Doc -> Doc -> Doc
406 splitWithLine _ Empty b = b
407 splitWithLine _ a Empty = a
408 splitWithLine f a b = a <> Line f <> b
409
410 -- | The document @softline@ behaves like 'space' if the resulting
411 -- output fits the page, otherwise it behaves like 'line'.
412 --
413 -- > softline = group line
414 softline :: Doc
415 softline = group line
416
417 -- | The document @softbreak@ behaves like 'empty' if the resulting
418 -- output fits the page, otherwise it behaves like 'line'.
419 --
420 -- > softbreak = group linebreak
421 softbreak :: Doc
422 softbreak = group linebreak
423
424 -- | The document @spacebreak@ behaves like 'space' when rendered normally
425 -- but like 'empty' when using 'renderCompact' or 'renderOneLine'.
426 spacebreak :: Doc
427 spacebreak = Spaces 1
428
429 -- | Document @(squotes x)@ encloses document @x@ with single quotes
430 -- \"'\".
431 squotes :: Doc -> Doc
432 squotes = enclose squote squote
433
434 -- | Document @(dquotes x)@ encloses document @x@ with double quotes
435 -- '\"'.
436 dquotes :: Doc -> Doc
437 dquotes = enclose dquote dquote
438
439 -- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and
440 -- \"}\".
441 braces :: Doc -> Doc
442 braces = enclose lbrace rbrace
443
444 -- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\"
445 -- and \")\".
446 parens :: Doc -> Doc
447 parens = enclose lparen rparen
448
449 -- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and
450 -- \"\>\".
451 angles :: Doc -> Doc
452 angles = enclose langle rangle
453
454 -- | Document @(brackets x)@ encloses document @x@ in square brackets,
455 -- \"[\" and \"]\".
456 brackets :: Doc -> Doc
457 brackets = enclose lbracket rbracket
458
459 -- | The document @(enclose l r x)@ encloses document @x@ between
460 -- documents @l@ and @r@ using @(\<\>)@.
461 --
462 -- > enclose l r x = l <> x <> r
463 enclose :: Doc -> Doc -> Doc -> Doc
464 enclose l r x = l <> x <> r
465
466 -- | The document @lparen@ contains a left parenthesis, \"(\".
467 lparen :: Doc
468 lparen = char '('
469
470 -- | The document @rparen@ contains a right parenthesis, \")\".
471 rparen :: Doc
472 rparen = char ')'
473
474 -- | The document @langle@ contains a left angle, \"\<\".
475 langle :: Doc
476 langle = char '<'
477
478 -- | The document @rangle@ contains a right angle, \">\".
479 rangle :: Doc
480 rangle = char '>'
481
482 -- | The document @lbrace@ contains a left brace, \"{\".
483 lbrace :: Doc
484 lbrace = char '{'
485
486 -- | The document @rbrace@ contains a right brace, \"}\".
487 rbrace :: Doc
488 rbrace = char '}'
489
490 -- | The document @lbracket@ contains a left square bracket, \"[\".
491 lbracket :: Doc
492 lbracket = char '['
493
494 -- | The document @rbracket@ contains a right square bracket, \"]\".
495 rbracket :: Doc
496 rbracket = char ']'
497
498 -- | The document @squote@ contains a single quote, \"'\".
499 squote :: Doc
500 squote = char '\''
501
502 -- | The document @dquote@ contains a double quote, '\"'.
503 dquote :: Doc
504 dquote = char '"'
505
506 -- | The document @semi@ contains a semi colon, \";\".
507 semi :: Doc
508 semi = char ';'
509
510 -- | The document @colon@ contains a colon, \":\".
511 colon :: Doc
512 colon = char ':'
513
514 -- | The document @comma@ contains a comma, \",\".
515 comma :: Doc
516 comma = char ','
517
518 -- | The document @space@ contains a single space, \" \".
519 --
520 -- > x <+> y = x <> space <> y
521 space :: Doc
522 space = char ' '
523
524 -- | The document @dot@ contains a single dot, \".\".
525 dot :: Doc
526 dot = char '.'
527
528 -- | The document @backslash@ contains a back slash, \"\\\".
529 backslash :: Doc
530 backslash = char '\\'
531
532 -- | The document @equals@ contains an equal sign, \"=\".
533 equals :: Doc
534 equals = char '='
535
536 -----------------------------------------------------------
537 -- Combinators for prelude types
538 -----------------------------------------------------------
539
540 -- string is like "text" but replaces '\n' by "line"
541
542 -- | The document @(string s)@ concatenates all characters in @s@
543 -- using @line@ for newline characters and @char@ for all other
544 -- characters. It is used instead of 'text' whenever the text
545 -- contains newline characters.
546 string :: Text -> Doc
547 string str = case T.uncons str of
548 Nothing -> empty
549 Just ('\n',str') -> line <> string str'
550 _ -> case (T.span (/='\n') str) of
551 (xs,ys) -> text xs <> string ys
552
553 -- | The document @(bool b)@ shows the literal boolean @b@ using
554 -- 'text'.
555 bool :: Bool -> Doc
556 bool b = text' b
557
558 -- | The document @(int i)@ shows the literal integer @i@ using
559 -- 'text'.
560 int :: Int -> Doc
561 int i = text' i
562
563 -- | The document @(integer i)@ shows the literal integer @i@ using
564 -- 'text'.
565 integer :: Integer -> Doc
566 integer i = text' i
567
568 -- | The document @(float f)@ shows the literal float @f@ using
569 -- 'text'.
570 float :: Float -> Doc
571 float f = text' f
572
573 -- | The document @(double d)@ shows the literal double @d@ using
574 -- 'text'.
575 double :: Double -> Doc
576 double d = text' d
577
578 -- | The document @(rational r)@ shows the literal rational @r@ using
579 -- 'text'.
580 rational :: Rational -> Doc
581 rational r = text' r
582
583 text' :: (Show a) => a -> Doc
584 text' = text . T.pack . show
585
586 -----------------------------------------------------------
587 -- overloading "pretty"
588 -----------------------------------------------------------
589
590 -- | The member @prettyList@ is only used to define the @instance
591 -- Pretty a => Pretty [a]@. In normal circumstances only the
592 -- @pretty@ function is used.
593 class Pretty a where
594 pretty :: a -> Doc
595
596 prettyList :: [a] -> Doc
597 prettyList = list . fmap pretty
598
599 instance Pretty a => Pretty [a] where
600 pretty = prettyList
601
602 instance Pretty Doc where
603 pretty = id
604
605 instance Pretty Text where
606 pretty = string
607
608 instance Pretty () where
609 pretty () = text' ()
610
611 instance Pretty Bool where
612 pretty b = bool b
613
614 instance Pretty Char where
615 pretty c = char c
616
617 prettyList s = string $ T.pack s
618
619 instance Pretty Int where
620 pretty i = int i
621
622 instance Pretty Integer where
623 pretty i = integer i
624
625 instance Pretty Float where
626 pretty f = float f
627
628 instance Pretty Double where
629 pretty d = double d
630
631 --instance Pretty Rational where
632 -- pretty r = rational r
633
634 instance (Pretty a,Pretty b) => Pretty (a,b) where
635 pretty (x,y) = tupled [pretty x, pretty y]
636
637 instance (Pretty a,Pretty b,Pretty c) => Pretty (a,b,c) where
638 pretty (x,y,z)= tupled [pretty x, pretty y, pretty z]
639
640 instance Pretty a => Pretty (Maybe a) where
641 pretty Nothing = empty
642
643 pretty (Just x) = pretty x
644
645 -----------------------------------------------------------
646 -- semi primitive: fill and fillBreak
647 -----------------------------------------------------------
648
649 -- | The document @(fillBreak i x)@ first renders document @x@. It
650 -- then appends @space@s until the width is equal to @i@. If the
651 -- width of @x@ is already larger than @i@, the nesting level is
652 -- increased by @i@ and a @line@ is appended. When we redefine
653 -- @ptype@ in the previous example to use @fillBreak@, we get a
654 -- useful variation of the previous output:
655 --
656 -- > ptype (name,tp)
657 -- > = fillBreak 6 (text name) <+> text "::" <+> text tp
658 --
659 -- The output will now be:
660 --
661 -- @
662 -- let empty :: Doc
663 -- nest :: Int -> Doc -> Doc
664 -- linebreak
665 -- :: Doc
666 -- @
667 fillBreak :: Int -> Doc -> Doc
668 fillBreak f x = width x (\w ->
669 if (w > f)
670 then nest f linebreak
671 else spaced (f - w)
672 )
673
674
675 -- | The document @(fill i x)@ renders document @x@. It then appends
676 -- @space@s until the width is equal to @i@. If the width of @x@ is
677 -- already larger, nothing is appended. This combinator is quite
678 -- useful in practice to output a list of bindings. The following
679 -- example demonstrates this.
680 --
681 -- > types = [("empty","Doc")
682 -- > ,("nest","Int -> Doc -> Doc")
683 -- > ,("linebreak","Doc")]
684 -- >
685 -- > ptype (name,tp)
686 -- > = fill 6 (text name) <+> text "::" <+> text tp
687 -- >
688 -- > test = text "let" <+> align (vcat (map ptype types))
689 --
690 -- Which is laid out as:
691 --
692 -- @
693 -- let empty :: Doc
694 -- nest :: Int -> Doc -> Doc
695 -- linebreak :: Doc
696 -- @
697 fill :: Int -> Doc -> Doc
698 fill f d = width d (\w ->
699 if (w >= f)
700 then empty
701 else spaced (f - w)
702 )
703
704
705 width :: Doc -> (Int -> Doc) -> Doc
706 width d f = column (\k1 -> d <> column (\k2 -> f (k2 - k1)))
707
708 -----------------------------------------------------------
709 -- semi primitive: Alignment and indentation
710 -----------------------------------------------------------
711
712 -- | The document @(indent i x)@ indents document @x@ with @i@ spaces.
713 --
714 -- > test = indent 4 (fillSep (map text
715 -- > (words "the indent combinator indents these words !")))
716 --
717 -- Which lays out with a page width of 20 as:
718 --
719 -- @
720 -- the indent
721 -- combinator
722 -- indents these
723 -- words !
724 -- @
725 indent :: Int -> Doc -> Doc
726 indent _ Empty = Empty
727 indent i d = hang i (spaced i <> d)
728
729 -- | The hang combinator implements hanging indentation. The document
730 -- @(hang i x)@ renders document @x@ with a nesting level set to the
731 -- current column plus @i@. The following example uses hanging
732 -- indentation for some text:
733 --
734 -- > test = hang 4 (fillSep (map text
735 -- > (words "the hang combinator indents these words !")))
736 --
737 -- Which lays out on a page with a width of 20 characters as:
738 --
739 -- @
740 -- the hang combinator
741 -- indents these
742 -- words !
743 -- @
744 --
745 -- The @hang@ combinator is implemented as:
746 --
747 -- > hang i x = align (nest i x)
748 hang :: Int -> Doc -> Doc
749 hang i d = align (nest i d)
750
751 -- | The document @(align x)@ renders document @x@ with the nesting
752 -- level set to the current column. It is used for example to
753 -- implement 'hang'.
754 --
755 -- As an example, we will put a document right above another one,
756 -- regardless of the current nesting level:
757 --
758 -- > x $$ y = align (x <$> y)
759 --
760 -- > test = text "hi" <+> (text "nice" $$ text "world")
761 --
762 -- which will be laid out as:
763 --
764 -- @
765 -- hi nice
766 -- world
767 -- @
768 align :: Doc -> Doc
769 align d = column (\k ->
770 nesting (\i -> nest (k - i) d)) --nesting might be negative :-)
771
772 -----------------------------------------------------------
773 -- Primitives
774 -----------------------------------------------------------
775
776 -- | The abstract data type @Doc@ represents pretty documents.
777 --
778 -- @Doc@ is an instance of the 'Show' class. @(show doc)@ pretty
779 -- prints document @doc@ with a page width of 100 characters and a
780 -- ribbon width of 40 characters.
781 --
782 -- > show (text "hello" <$> text "world")
783 --
784 -- Which would return the string \"hello\\nworld\", i.e.
785 --
786 -- @
787 -- hello
788 -- world
789 -- @
790 data Doc = Empty
791 | Char Char -- invariant: char is not '\n'
792 | Text !Int64 Builder -- invariant: text doesn't contain '\n'
793 | Line !Bool -- True <=> when undone by group, do not insert a space
794 -- | FlatAlt Doc Doc -- Render the first doc, but when
795 -- flattened, render the second.
796 | Cat Doc Doc
797 | Nest !Int64 Doc
798 | Union Doc Doc -- invariant: first lines of first doc longer than the first lines of the second doc
799 | Column (Int64 -> Doc)
800 | Nesting (Int64 -> Doc)
801 | Spaces !Int64
802 | Color ConsoleLayer ColorIntensity -- Introduces coloring /around/ the embedded document
803 Color Doc
804 | IfColor Doc Doc
805 | Intensify ConsoleIntensity Doc
806 | Italicize Bool Doc
807 | Underline Underlining Doc
808 | RestoreFormat (Maybe (ColorIntensity, Color)) -- Only used during the rendered phase, to signal a SGR should be issued to restore the terminal formatting.
809 (Maybe (ColorIntensity, Color)) -- These are the colors to revert the current forecolor/backcolor to (i.e. those from before the start of the Color block).
810 (Maybe ConsoleIntensity) -- Intensity to revert to.
811 (Maybe Bool) -- Italicization to revert to.
812 (Maybe Underlining) -- Underlining to revert to.
813
814 instance IsString Doc where
815 fromString = string . T.pack
816
817 -- | In particular, note that the document @(x '<>' y)@ concatenates
818 -- document @x@ and document @y@. It is an associative operation
819 -- having 'empty' as a left and right unit. (infixr 6)
820 instance Monoid Doc where
821 mempty = empty
822 mappend = beside
823
824 -- | The data type @SimpleDoc@ represents rendered documents and is
825 -- used by the display functions.
826 --
827 -- The @Int@ in @SText@ contains the length of the string. The @Int@
828 -- in @SLine@ contains the indentation for that line. The library
829 -- provides two default display functions 'displayS' and
830 -- 'displayIO'. You can provide your own display function by writing
831 -- a function from a @SimpleDoc@ to your own output format.
832 data SimpleDoc = SEmpty
833 | SChar Char SimpleDoc
834 | SText !Int64 Builder SimpleDoc
835 | SLine !Int64 SimpleDoc
836 | SSGR [SGR] SimpleDoc
837
838 -- | The empty document is, indeed, empty. Although @empty@ has no
839 -- content, it does have a \'height\' of 1 and behaves exactly like
840 -- @(text \"\")@ (and is therefore not a unit of @\<$\>@).
841 empty :: Doc
842 empty = Empty
843
844 is_empty :: Doc -> Bool
845 is_empty doc = case doc of
846 Empty -> True
847 _ -> False
848
849 if_color :: Doc -> Doc -> Doc
850 if_color = IfColor
851
852 -- | The document @(char c)@ contains the literal character @c@. The
853 -- character shouldn't be a newline (@'\n'@), the function 'line'
854 -- should be used for line breaks.
855 char :: Char -> Doc
856 char '\n' = line
857 char c = Char c
858
859 -- | The document @(text s)@ contains the literal string @s@. The
860 -- string shouldn't contain any newline (@'\n'@) characters. If the
861 -- string contains newline characters, the function 'string' should
862 -- be used.
863 text :: Text -> Doc
864 text s
865 | T.null s = Empty
866 | otherwise = Text (T.length s) (B.fromLazyText s)
867
868 -- | The @line@ document advances to the next line and indents to the
869 -- current nesting level. Document @line@ behaves like @(text \"
870 -- \")@ if the line break is undone by 'group' or if rendered with
871 -- 'renderOneLine'.
872 line :: Doc
873 line = Line False
874 --line = FlatAlt Line space
875
876 -- | The @linebreak@ document advances to the next line and indents to
877 -- the current nesting level. Document @linebreak@ behaves like
878 -- 'empty' if the line break is undone by 'group'.
879 linebreak :: Doc
880 linebreak = Line True
881 --linebreak = FlatAlt Line empty
882
883 beside :: Doc -> Doc -> Doc
884 beside Empty r = r
885 beside l Empty = l
886 beside l r = Cat l r
887
888 -- | The document @(nest i x)@ renders document @x@ with the current
889 -- indentation level increased by @i@ (See also 'hang', 'align' and
890 -- 'indent').
891 --
892 -- > nest 2 (text "hello" <$> text "world") <$> text "!"
893 --
894 -- outputs as:
895 --
896 -- @
897 -- hello
898 -- world
899 -- !
900 -- @
901 nest :: Int -> Doc -> Doc
902 nest _ Empty = Empty
903 nest i x = Nest (fromIntegral i) x
904
905 -- | Specifies how to create the document based upon which column it is in.
906 column :: (Int -> Doc) -> Doc
907 column f = Column (f . fromIntegral)
908
909 -- | Specifies how to nest the document based upon which column it is
910 -- being nested in.
911 nesting :: (Int -> Doc) -> Doc
912 nesting f = Nesting (f . fromIntegral)
913
914 -- | The @group@ combinator is used to specify alternative
915 -- layouts. The document @(group x)@ undoes all line breaks in
916 -- document @x@. The resulting line is added to the current line if
917 -- that fits the page. Otherwise, the document @x@ is rendered
918 -- without any changes.
919 group :: Doc -> Doc
920 group x = Union (flatten x) x
921
922 flatten :: Doc -> Doc
923 flatten (Cat x y) = Cat (flatten x) (flatten y)
924 flatten (Nest i x) = Nest i (flatten x)
925 flatten (Line brk) = if brk then Empty else Text 1 (B.singleton ' ')
926 flatten (Union x _) = flatten x
927 flatten (Column f) = Column (flatten . f)
928 flatten (Nesting f) = Nesting (flatten . f)
929 flatten (Color l i c x) = Color l i c (flatten x)
930 flatten (IfColor t f) = IfColor (flatten t) (flatten f)
931 flatten (Intensify i x) = Intensify i (flatten x)
932 flatten (Italicize b x) = Italicize b (flatten x)
933 flatten (Underline u x) = Underline u (flatten x)
934 -- flatten (FlatAlt x y) = y
935 flatten other = other --Empty,Char,Text,RestoreFormat
936
937
938 -----------------------------------------------------------
939 -- Colors
940 -----------------------------------------------------------
941
942 -- | Displays a document with the black forecolor
943 black :: Doc -> Doc
944 -- | Displays a document with the red forecolor
945 red :: Doc -> Doc
946 -- | Displays a document with the green forecolor
947 green :: Doc -> Doc
948 -- | Displays a document with the yellow forecolor
949 yellow :: Doc -> Doc
950 -- | Displays a document with the blue forecolor
951 blue :: Doc -> Doc
952 -- | Displays a document with the magenta forecolor
953 magenta :: Doc -> Doc
954 -- | Displays a document with the cyan forecolor
955 cyan :: Doc -> Doc
956 -- | Displays a document with the white forecolor
957 white :: Doc -> Doc
958 -- | Displays a document with the dull black forecolor
959 dullblack :: Doc -> Doc
960 -- | Displays a document with the dull red forecolor
961 dullred :: Doc -> Doc
962 -- | Displays a document with the dull green forecolor
963 dullgreen :: Doc -> Doc
964 -- | Displays a document with the dull yellow forecolor
965 dullyellow :: Doc -> Doc
966 -- | Displays a document with the dull blue forecolor
967 dullblue :: Doc -> Doc
968 -- | Displays a document with the dull magenta forecolor
969 dullmagenta :: Doc -> Doc
970 -- | Displays a document with the dull cyan forecolor
971 dullcyan :: Doc -> Doc
972 -- | Displays a document with the dull white forecolor
973 dullwhite :: Doc -> Doc
974 (black, dullblack) = colorFunctions Black
975 (red, dullred) = colorFunctions Red
976 (green, dullgreen) = colorFunctions Green
977 (yellow, dullyellow) = colorFunctions Yellow
978 (blue, dullblue) = colorFunctions Blue
979 (magenta, dullmagenta) = colorFunctions Magenta
980 (cyan, dullcyan) = colorFunctions Cyan
981 (white, dullwhite) = colorFunctions White
982
983 -- | Displays a document with a forecolor given in the first parameter
984 color :: Color -> Doc -> Doc
985 -- | Displays a document with a dull forecolor given in the first parameter
986 dullcolor :: Color -> Doc -> Doc
987 color = Color Foreground Vivid
988 dullcolor = Color Foreground Dull
989
990 colorFunctions :: Color -> (Doc -> Doc, Doc -> Doc)
991 colorFunctions what = (color what, dullcolor what)
992
993 -- | Displays a document with the black backcolor
994 onblack :: Doc -> Doc
995 -- | Displays a document with the red backcolor
996 onred :: Doc -> Doc
997 -- | Displays a document with the green backcolor
998 ongreen :: Doc -> Doc
999 -- | Displays a document with the yellow backcolor
1000 onyellow :: Doc -> Doc
1001 -- | Displays a document with the blue backcolor
1002 onblue :: Doc -> Doc
1003 -- | Displays a document with the magenta backcolor
1004 onmagenta :: Doc -> Doc
1005 -- | Displays a document with the cyan backcolor
1006 oncyan :: Doc -> Doc
1007 -- | Displays a document with the white backcolor
1008 onwhite :: Doc -> Doc
1009 -- | Displays a document with the dull block backcolor
1010 ondullblack :: Doc -> Doc
1011 -- | Displays a document with the dull red backcolor
1012 ondullred :: Doc -> Doc
1013 -- | Displays a document with the dull green backcolor
1014 ondullgreen :: Doc -> Doc
1015 -- | Displays a document with the dull yellow backcolor
1016 ondullyellow :: Doc -> Doc
1017 -- | Displays a document with the dull blue backcolor
1018 ondullblue :: Doc -> Doc
1019 -- | Displays a document with the dull magenta backcolor
1020 ondullmagenta :: Doc -> Doc
1021 -- | Displays a document with the dull cyan backcolor
1022 ondullcyan :: Doc -> Doc
1023 -- | Displays a document with the dull white backcolor
1024 ondullwhite :: Doc -> Doc
1025 (onblack, ondullblack) = oncolorFunctions Black
1026 (onred, ondullred) = oncolorFunctions Red
1027 (ongreen, ondullgreen) = oncolorFunctions Green
1028 (onyellow, ondullyellow) = oncolorFunctions Yellow
1029 (onblue, ondullblue) = oncolorFunctions Blue
1030 (onmagenta, ondullmagenta) = oncolorFunctions Magenta
1031 (oncyan, ondullcyan) = oncolorFunctions Cyan
1032 (onwhite, ondullwhite) = oncolorFunctions White
1033
1034 -- | Displays a document with a backcolor given in the first parameter
1035 oncolor :: Color -> Doc -> Doc
1036 -- | Displays a document with a dull backcolor given in the first parameter
1037 ondullcolor :: Color -> Doc -> Doc
1038 oncolor = Color Background Vivid
1039 ondullcolor = Color Background Dull
1040
1041 oncolorFunctions :: Color -> (Doc -> Doc, Doc -> Doc)
1042 oncolorFunctions what = (oncolor what, ondullcolor what)
1043
1044
1045 -----------------------------------------------------------
1046 -- Console Intensity
1047 -----------------------------------------------------------
1048
1049 -- | Displays a document in a heavier font weight
1050 bold :: Doc -> Doc
1051 bold = Intensify BoldIntensity
1052
1053 -- | Displays a document in the normal font weight
1054 debold :: Doc -> Doc
1055 debold = Intensify NormalIntensity
1056
1057 -- NB: I don't support FaintIntensity here because it is not widely supported by terminals.
1058
1059
1060 -----------------------------------------------------------
1061 -- Italicization
1062 -----------------------------------------------------------
1063
1064 {-
1065
1066 I'm in two minds about providing these functions, since italicization is so rarely implemented.
1067 It is especially bad because "italicization" may cause the meaning of colors to flip, which will
1068 look a bit weird, to say the least...
1069
1070
1071 -- | Displays a document in italics. This is not widely supported, and it's use is not recommended
1072 italicize :: Doc -> Doc
1073 italicize = Italicize True
1074
1075 -- | Displays a document with no italics
1076 deitalicize :: Doc -> Doc
1077 deitalicize = Italicize False
1078
1079 -}
1080
1081 -----------------------------------------------------------
1082 -- Underlining
1083 -----------------------------------------------------------
1084
1085 -- | Displays a document with underlining
1086 underline :: Doc -> Doc
1087 underline = Underline SingleUnderline
1088
1089 -- | Displays a document with no underlining
1090 deunderline :: Doc -> Doc
1091 deunderline = Underline NoUnderline
1092
1093 -- NB: I don't support DoubleUnderline here because it is not widely supported by terminals.
1094
1095 -----------------------------------------------------------
1096 -- Removing formatting
1097 -----------------------------------------------------------
1098
1099 -- | Removes all colorisation, emboldening and underlining from a document
1100 plain :: Doc -> Doc
1101 -- plain Fail = Fail
1102 plain e@Empty = e
1103 plain c@(Char _) = c
1104 plain t@(Text _ _) = t
1105 plain l@(Line _) = l
1106 -- plain (FlatAlt x y) = FlatAlt (plain x) (plain y)
1107 plain (Cat x y) = Cat (plain x) (plain y)
1108 plain (Nest i x) = Nest i (plain x)
1109 plain (Union x y) = Union (plain x) (plain y)
1110 plain (Column f) = Column (plain . f)
1111 -- plain (Columns f) = Columns (plain . f)
1112 plain (Nesting f) = Nesting (plain . f)
1113 plain (Spaces l) = Spaces l
1114 plain (Color _ _ _ x) = plain x
1115 plain (Intensify _ x) = plain x
1116 plain (IfColor t f) = IfColor (plain t) (plain f)
1117 plain (Italicize _ x) = plain x
1118 plain (Underline _ x) = plain x
1119 plain (RestoreFormat{}) = Empty
1120
1121 -----------------------------------------------------------
1122 -- Renderers
1123 -----------------------------------------------------------
1124
1125 -----------------------------------------------------------
1126 -- renderPretty: the default pretty printing algorithm
1127 -----------------------------------------------------------
1128
1129 -- list of indentation/document pairs; saves an indirection over [(Int,Doc)]
1130 data Docs = Nil
1131 | Cons !Int64 Doc Docs
1132
1133 -- | This is the default pretty printer which is used by 'show',
1134 -- 'putDoc' and 'hPutDoc'. @(renderPretty ribbonfrac width x)@
1135 -- renders document @x@ with a page width of @width@ and a ribbon
1136 -- width of @(ribbonfrac * width)@ characters. The ribbon width is
1137 -- the maximal amount of non-indentation characters on a line. The
1138 -- parameter @ribbonfrac@ should be between @0.0@ and @1.0@. If it
1139 -- is lower or higher, the ribbon width will be 0 or @width@
1140 -- respectively.
1141 renderPretty :: Bool -> Float -> Int -> Doc -> SimpleDoc
1142 renderPretty = renderFits fits1
1143
1144 -- | A slightly smarter rendering algorithm with more lookahead. It provides
1145 -- provide earlier breaking on deeply nested structures
1146 -- For example, consider this python-ish pseudocode:
1147 -- @fun(fun(fun(fun(fun([abcdefg, abcdefg])))))@
1148 -- If we put a softbreak (+ nesting 2) after each open parenthesis, and align
1149 -- the elements of the list to match the opening brackets, this will render with
1150 -- @renderPretty@ and a page width of 20 as:
1151 -- @
1152 -- fun(fun(fun(fun(fun([
1153 -- | abcdef,
1154 -- | abcdef,
1155 -- ]
1156 -- ))))) |
1157 -- @
1158 -- Where the 20c. boundary has been marked with |.
1159 -- Because @renderPretty@ only uses one-line lookahead, it sees that the first
1160 -- line fits, and is stuck putting the second and third lines after the 20-c
1161 -- mark. In contrast, @renderSmart@ will continue to check that the potential
1162 -- document up to the end of the indentation level. Thus, it will format the
1163 -- document as:
1164 --
1165 -- @
1166 -- fun( |
1167 -- fun( |
1168 -- fun( |
1169 -- fun( |
1170 -- fun([ |
1171 -- abcdef,
1172 -- abcdef,
1173 -- ] |
1174 -- ))))) |
1175 -- @
1176 -- Which fits within the 20c. boundary.
1177 renderSmart :: Bool -> Float -> Int -> Doc -> SimpleDoc
1178 renderSmart = renderFits fitsR
1179
1180 renderFits :: (Int64 -> Int64 -> Int64 -> SimpleDoc -> Bool)
1181 -> Bool -> Float -> Int -> Doc -> SimpleDoc
1182 renderFits fits with_color rfrac w doc
1183 -- I used to do a @SSGR [Reset]@ here, but if you do that it will result
1184 -- in any rendered @Doc@ containing at least some ANSI control codes. This
1185 -- may be undesirable if you want to render to non-ANSI devices by simply
1186 -- not making use of the ANSI color combinators I provide.
1187 --
1188 -- What I "really" want to do here is do an initial Reset iff there is some
1189 -- ANSI color within the Doc, but that's a bit fiddly. I'll fix it if someone
1190 -- complains!
1191 = best 0 0 Nothing Nothing Nothing Nothing Nothing (Cons 0 doc Nil)
1192 where
1193 -- r :: the ribbon width in characters
1194 r = max 0 (min w64 (round (fromIntegral w * rfrac)))
1195
1196 w64 = fromIntegral w
1197
1198 -- best :: n = indentation of current line
1199 -- k = current column
1200 -- (ie. (k >= n) && (k - n == count of inserted characters)
1201 best _n _k _mb_fc _mb_bc _mb_in _mb_it _mb_un Nil = SEmpty
1202 best n k mb_fc mb_bc mb_in mb_it mb_un (Cons i d ds)
1203 = case d of
1204 -- Fail -> SFail
1205 Empty -> best_typical n k ds
1206 Char c -> let k' = k+1 in seq k' (SChar c (best_typical n k' ds))
1207 Text l s -> let k' = k+l in seq k' (SText l s (best_typical n k' ds))
1208 Line _ -> SLine i (best_typical i i ds)
1209 -- FlatAlt x _ -> best_typical n k (Cons i x ds)
1210 Cat x y -> best_typical n k (Cons i x (Cons i y ds))
1211 Nest j x -> let i' = i+j in seq i' (best_typical n k (Cons i' x ds))
1212 Union x y -> nicest n k (best_typical n k (Cons i x ds))
1213 (best_typical n k (Cons i y ds))
1214 Column f -> best_typical n k (Cons i (f k) ds)
1215 -- Columns f -> best_typical n k (Cons i (f (Just w)) ds)
1216 Nesting f -> best_typical n k (Cons i (f i) ds)
1217 Spaces l -> let k' = k+l in seq k' $ SText l (spaces l) (best_typical n k' ds)
1218 Color _ _ _ x | not with_color -> best_typical n k (Cons i x ds)
1219 Color l t c x -> SSGR [SetColor l t c] (best n k mb_fc' mb_bc' mb_in mb_it mb_un (Cons i x ds_restore))
1220 where
1221 mb_fc' = case l of { Background -> mb_fc; Foreground -> Just (t, c) }
1222 mb_bc' = case l of { Background -> Just (t, c); Foreground -> mb_bc }
1223 IfColor xt xf -> best_typical n k (if with_color then Cons i xt ds else Cons i xf ds)
1224 Intensify _ x | not with_color -> best_typical n k (Cons i x ds)
1225 Intensify t x -> SSGR [SetConsoleIntensity t] (best n k mb_fc mb_bc (Just t) mb_it mb_un (Cons i x ds_restore))
1226 Italicize _ x | not with_color -> best_typical n k (Cons i x ds)
1227 Italicize t x -> SSGR [SetItalicized t] (best n k mb_fc mb_bc mb_in (Just t) mb_un (Cons i x ds_restore))
1228 Underline _ x | not with_color -> best_typical n k (Cons i x ds)
1229 Underline u x -> SSGR [SetUnderlining u] (best n k mb_fc mb_bc mb_in mb_it (Just u) (Cons i x ds_restore))
1230 RestoreFormat{} | not with_color -> best_typical n k ds
1231 RestoreFormat mb_fc' mb_bc' mb_in' mb_it' mb_un' -> SSGR sgrs (best n k mb_fc' mb_bc' mb_in' mb_it' mb_un' ds)
1232 where
1233 -- We need to be able to restore the entire SGR state, hence we carry around what we believe
1234 -- that state should be in all the arguments to this function. Note that in some cases we could
1235 -- avoid the Reset of the entire state, but not in general.
1236 sgrs = Reset : catMaybes [
1237 fmap (uncurry (SetColor Foreground)) mb_fc',
1238 fmap (uncurry (SetColor Background)) mb_bc',
1239 fmap SetConsoleIntensity mb_in',
1240 fmap SetItalicized mb_it',
1241 fmap SetUnderlining mb_un'
1242 ]
1243 where
1244 best_typical n' k' ds' = best n' k' mb_fc mb_bc mb_in mb_it mb_un ds'
1245 ds_restore = Cons i (RestoreFormat mb_fc mb_bc mb_in mb_it mb_un) ds
1246
1247 --nicest :: r = ribbon width, w = page width,
1248 -- n = indentation of current line, k = current column
1249 -- x and y, the (simple) documents to chose from.
1250 -- precondition: first lines of x are longer than the first lines of y.
1251 nicest n k x y | fits w64 (min n k) width_ x = x
1252 | otherwise = y
1253 where
1254 width_ = min (w64 - k) (r - k + n)
1255
1256 -- @fits1@ does 1 line lookahead.
1257 fits1 :: Int64 -> Int64 -> Int64 -> SimpleDoc -> Bool
1258 fits1 _ _ w _x | w < 0 = False
1259 --fits1 _ _ w SFail = False
1260 fits1 _ _ _w SEmpty = True
1261 fits1 p m w (SChar _c x) = fits1 p m (w - 1) x
1262 fits1 p m w (SText l _s x) = fits1 p m (w - l) x
1263 fits1 _ _ _w (SLine _i _x) = True
1264 fits1 p m w (SSGR _ x) = fits1 p m w x
1265
1266 -- @fitsR@ has a little more lookahead: assuming that nesting roughly
1267 -- corresponds to syntactic depth, @fitsR@ checks that not only the current line
1268 -- fits, but the entire syntactic structure being formatted at this level of
1269 -- indentation fits. If we were to remove the second case for @SLine@, we would
1270 -- check that not only the current structure fits, but also the rest of the
1271 -- document, which would be slightly more intelligent but would have exponential
1272 -- runtime (and is prohibitively expensive in practice).
1273 -- p = pagewidth
1274 -- m = minimum nesting level to fit in
1275 -- w = the width in which to fit the first line
1276 fitsR :: Int64 -> Int64 -> Int64 -> SimpleDoc -> Bool
1277 fitsR _p _m w _x | w < 0 = False
1278 --fitsR p m w SFail = False
1279 fitsR _p _m _w SEmpty = True
1280 fitsR p m w (SChar _c x) = fitsR p m (w - 1) x
1281 fitsR p m w (SText l _s x) = fitsR p m (w - l) x
1282 fitsR p m _w (SLine i x) | m < i = fitsR p m (p - i) x
1283 | otherwise = True
1284 fitsR p m w (SSGR _ x) = fitsR p m w x
1285
1286 -----------------------------------------------------------
1287 -- renderCompact: renders documents without indentation
1288 -- fast and fewer characters output, good for machines
1289 -----------------------------------------------------------
1290
1291
1292 -- | @(renderCompact x)@ renders document @x@ without adding any
1293 -- indentation. Since no \'pretty\' printing is involved, this
1294 -- renderer is very fast. The resulting output contains fewer
1295 -- characters than a pretty printed version and can be used for
1296 -- output that is read by other programs.
1297 renderCompact :: Bool -> Doc -> SimpleDoc
1298 renderCompact with_color dc
1299 = scan 0 Nothing Nothing Nothing Nothing Nothing [dc]
1300 where
1301 scan _ _mb_fc _mb_bc _mb_in _mb_it _mb_un [] = SEmpty
1302 scan k mb_fc mb_bc mb_in mb_it mb_un (d:ds)
1303 = case d of
1304 Empty -> scan' k ds
1305 Char c -> let k' = k+1 in seq k' (SChar c (scan' k' ds))
1306 Text l s -> let k' = k+l in seq k' (SText l s (scan' k' ds))
1307 Line _ -> SLine 0 (scan' 0 ds)
1308 -- FlatAlt x _ -> scan' k (x:ds)
1309 Cat x y -> scan' k (x:y:ds)
1310 Nest _ x -> scan' k (x:ds)
1311 Union _ y -> scan' k (y:ds)
1312 Column f -> scan' k (f k:ds)
1313 -- Columns f -> scan' k (f Nothing:ds)
1314 Nesting f -> scan' k (f 0:ds)
1315 Spaces _ -> scan' k ds
1316 Color _ _ _ x | not with_color -> scan' k (x:ds)
1317 Color l t c x -> SSGR [SetColor l t c] (scan k mb_fc' mb_bc' mb_in mb_it mb_un (x:ds_restore))
1318 where
1319 mb_fc' = case l of { Background -> mb_fc; Foreground -> Just (t, c) }
1320 mb_bc' = case l of { Background -> Just (t, c); Foreground -> mb_bc }
1321 IfColor x _ | not with_color -> scan' k (x:ds)
1322 IfColor _ x -> scan' k (x:ds)
1323 Intensify _ x | not with_color -> scan' k (x:ds)
1324 Intensify t x -> SSGR [SetConsoleIntensity t] (scan k mb_fc mb_bc (Just t) mb_it mb_un (x:ds_restore))
1325 Italicize _ x | not with_color -> scan' k (x:ds)
1326 Italicize t x -> SSGR [SetItalicized t] (scan k mb_fc mb_bc mb_in (Just t) mb_un (x:ds_restore))
1327 Underline _ x | not with_color -> scan' k (x:ds)
1328 Underline u x -> SSGR [SetUnderlining u] (scan k mb_fc mb_bc mb_in mb_it (Just u) (x:ds_restore))
1329 RestoreFormat{} | not with_color -> scan' k ds
1330 RestoreFormat mb_fc' mb_bc' mb_in' mb_it' mb_un' -> SSGR sgrs (scan k mb_fc' mb_bc' mb_in' mb_it' mb_un' ds)
1331 where
1332 sgrs = Reset : catMaybes [
1333 fmap (uncurry (SetColor Foreground)) mb_fc',
1334 fmap (uncurry (SetColor Background)) mb_bc',
1335 fmap SetConsoleIntensity mb_in',
1336 fmap SetItalicized mb_it',
1337 fmap SetUnderlining mb_un'
1338 ]
1339 where
1340 scan' k' ds' = scan k' mb_fc mb_bc mb_in mb_it mb_un ds'
1341 ds_restore = RestoreFormat mb_fc mb_bc mb_in mb_it mb_un:ds
1342
1343 -- | @(renderOneLine x)@ renders document @x@ without adding any
1344 -- indentation or newlines.
1345 renderOneLine :: Bool -> Doc -> SimpleDoc
1346 renderOneLine with_color dc
1347 = scan 0 Nothing Nothing Nothing Nothing Nothing [dc]
1348 where
1349 scan _ _mb_fc _mb_bc _mb_in _mb_it _mb_un [] = SEmpty
1350 scan k mb_fc mb_bc mb_in mb_it mb_un (d:ds)
1351 = case d of
1352 Empty -> scan' k ds
1353 Char c -> let k' = k+1 in seq k' (SChar c (scan' k' ds))
1354 Text l s -> let k' = k+l in seq k' (SText l s (scan' k' ds))
1355 Line False -> let k' = k+1 in seq k' (SChar ' ' (scan' k' ds))
1356 Line _ -> scan' k ds
1357 Cat x y -> scan' k (x:y:ds)
1358 Nest _ x -> scan' k (x:ds)
1359 Union _ y -> scan' k (y:ds)
1360 Column f -> scan' k (f k:ds)
1361 Nesting f -> scan' k (f 0:ds)
1362 Spaces _ -> scan' k ds
1363 Color _ _ _ x | not with_color -> scan' k (x:ds)
1364 Color l t c x -> SSGR [SetColor l t c] (scan k mb_fc' mb_bc' mb_in mb_it mb_un (x:ds_restore))
1365 where
1366 mb_fc' = case l of { Background -> mb_fc; Foreground -> Just (t, c) }
1367 mb_bc' = case l of { Background -> Just (t, c); Foreground -> mb_bc }
1368 IfColor x _ | with_color -> scan' k (x:ds)
1369 IfColor _ x -> scan' k (x:ds)
1370 Intensify _ x | with_color -> scan' k (x:ds)
1371 Intensify t x -> SSGR [SetConsoleIntensity t] (scan k mb_fc mb_bc (Just t) mb_it mb_un (x:ds_restore))
1372 Italicize _ x | with_color -> scan' k (x:ds)
1373 Italicize t x -> SSGR [SetItalicized t] (scan k mb_fc mb_bc mb_in (Just t) mb_un (x:ds_restore))
1374 Underline _ x | with_color -> scan' k (x:ds)
1375 Underline u x -> SSGR [SetUnderlining u] (scan k mb_fc mb_bc mb_in mb_it (Just u) (x:ds_restore))
1376 RestoreFormat{} | with_color -> scan' k ds
1377 RestoreFormat mb_fc' mb_bc' mb_in' mb_it' mb_un' -> SSGR sgrs (scan k mb_fc' mb_bc' mb_in' mb_it' mb_un' ds)
1378 where
1379 sgrs = Reset : catMaybes [
1380 fmap (uncurry (SetColor Foreground)) mb_fc',
1381 fmap (uncurry (SetColor Background)) mb_bc',
1382 fmap SetConsoleIntensity mb_in',
1383 fmap SetItalicized mb_it',
1384 fmap SetUnderlining mb_un'
1385 ]
1386 where
1387 scan' k' ds' = scan k' mb_fc mb_bc mb_in mb_it mb_un ds'
1388 ds_restore = RestoreFormat mb_fc mb_bc mb_in mb_it mb_un:ds
1389
1390 -----------------------------------------------------------
1391 -- Displayers: displayS and displayIO
1392 -----------------------------------------------------------
1393
1394
1395 -- | @(displayB simpleDoc)@ takes the output @simpleDoc@ from a
1396 -- rendering function and transforms it to a 'Builder' type (for
1397 -- further manipulation before converting to a lazy 'Text').
1398 displayB :: SimpleDoc -> Builder
1399 displayB SEmpty = mempty
1400 displayB (SChar c x) = c `consB` displayB x
1401 displayB (SText _ s x) = s `mappend` displayB x
1402 displayB (SLine i x) = '\n' `consB` (indentation i `mappend` displayB x)
1403 displayB (SSGR s x) = B.fromLazyText (T.pack (setSGRCode s)) `mappend` displayB x
1404
1405 consB :: Char -> Builder -> Builder
1406 c `consB` b = B.singleton c `mappend` b
1407
1408 -- | @(displayT simpleDoc)@ takes the output @simpleDoc@ from a
1409 -- rendering function and transforms it to a lazy 'Text' value.
1410 --
1411 -- > showWidth :: Int -> Doc -> Text
1412 -- > showWidth w x = displayT (renderPretty 0.4 w x)
1413 displayT :: SimpleDoc -> Text
1414 displayT = B.toLazyText . displayB
1415
1416 -- | @(displayIO handle simpleDoc)@ writes @simpleDoc@ to the
1417 -- file handle @handle@. This function is used for example by
1418 -- 'hPutDoc':
1419 --
1420 -- > hPutDoc handle doc = displayIO handle (renderPretty 0.4 100 doc)
1421 displayIO :: Handle -> SimpleDoc -> IO ()
1422 displayIO handle simpleDoc
1423 = display simpleDoc
1424 where
1425 display SEmpty = return ()
1426 display (SChar c x) = hPutChar handle c >> display x
1427 display (SText _ s x) = T.hPutStr handle (B.toLazyText s) >> display x
1428 display (SLine i x) = T.hPutStr handle newLine >> display x
1429 where
1430 newLine = B.toLazyText $ '\n' `consB` indentation i
1431 display (SSGR s x) = hSetSGR handle s >> display x
1432
1433 -----------------------------------------------------------
1434 -- default pretty printers: show, putDoc and hPutDoc
1435 -----------------------------------------------------------
1436
1437 instance Show Doc where
1438 showsPrec d doc = showsPrec d (displayT $ renderPretty True 0.4 80 doc)
1439 show doc = T.unpack (displayT $ renderPretty True 0.4 80 doc)
1440
1441 instance Show SimpleDoc where
1442 show simpleDoc = T.unpack (displayT simpleDoc)
1443
1444 -- | The action @(putDoc doc)@ pretty prints document @doc@ to the
1445 -- standard output, with a page width of 100 characters and a ribbon
1446 -- width of 40 characters.
1447 --
1448 -- > main :: IO ()
1449 -- > main = do{ putDoc (text "hello" <+> text "world") }
1450 --
1451 -- Which would output
1452 --
1453 -- @
1454 -- hello world
1455 -- @
1456 putDoc :: Doc -> IO ()
1457 putDoc doc = hPutDoc stdout doc
1458
1459 -- | @(hPutDoc handle doc)@ pretty prints document @doc@ to the file
1460 -- handle @handle@ with a page width of 100 characters and a ribbon
1461 -- width of 40 characters.
1462 --
1463 -- > main = do handle <- 'openFile' "MyFile" 'WriteMode'
1464 -- > 'hPutDoc' handle ('vcat' ('map' 'text'
1465 -- > ['T.pack' "vertical", 'T.pack' "text"]))
1466 -- > 'hClose' handle
1467 hPutDoc :: Handle -> Doc -> IO ()
1468 hPutDoc handle doc = displayIO handle (renderPretty True 0.4 80 doc)
1469
1470 -----------------------------------------------------------
1471 -- insert spaces
1472 -- "indentation" used to insert tabs but tabs seem to cause
1473 -- more trouble than they solve :-)
1474 -----------------------------------------------------------
1475 spaces :: Int64 -> Builder
1476 spaces n
1477 | n <= 0 = mempty
1478 | otherwise = B.fromLazyText $ T.replicate n (T.singleton ' ')
1479
1480 spaced :: Int -> Doc
1481 spaced l = Spaces l'
1482 where
1483 l' = fromIntegral l
1484
1485 -- An alias for readability purposes
1486 indentation :: Int64 -> Builder
1487 indentation = spaces
1488
1489 -- | Return a 'Doc' from a strict 'Text'
1490 strict_text :: Data.Text.Text -> Doc
1491 strict_text = text . T.fromStrict
1492
1493 -- | Return a 'Doc' concatenating converted values of a 'Foldable'
1494 -- separated by a given 'Doc'.
1495 intercalate
1496 :: Data.Foldable.Foldable t
1497 => Doc -> (a -> Doc) -> t a -> Doc
1498 intercalate separator f =
1499 Data.Foldable.foldl
1500 (\doc x -> doc <> (if is_empty doc then empty else separator) <> f x)
1501 empty
1502
1503 class ToDoc m a where
1504 toDoc :: m -> a -> Doc
1505 instance ToDoc () Doc where
1506 toDoc () = id
1507
1508 -- ** Class 'Leijen_of_forall_param'
1509
1510 -- | A class useful when using a context of kind '*' is not wanted
1511 -- for example in a class instance constraint
1512 -- to keep the instance decidable (i.e. avoid UndecidableInstances).
1513 class Leijen_of_forall_param f x where
1514 leijen_of_forall_param :: forall m. f m -> x -> Doc
1515
1516 -- LocalWords: PPrint combinators Wadler Wadler's encloseSep