├── Setup.lhs ├── .gitignore ├── README.textile ├── LICENSE ├── Text └── PrettyPrint │ └── ANSI │ ├── Example.hs │ └── Leijen.hs ├── release └── ansi-wl-pprint.cabal /Setup.lhs: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env runhaskell 2 | > import Distribution.Simple 3 | > main = defaultMain -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # OS Junk 2 | .DS_Store 3 | Thumbs.db 4 | 5 | # Build artifacts 6 | dist/ 7 | *.hi 8 | *.o 9 | -------------------------------------------------------------------------------- /README.textile: -------------------------------------------------------------------------------- 1 | h1. ANSI Wadler/Leijen Pretty Printer 2 | 3 | For all information on this package, please consult the "homepage":http://batterseapower.github.com/ansi-wl-pprint -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright 2008, Daan Leijen and Max Bolingbroke. All rights reserved. 2 | 3 | Redistribution and use in source and binary forms, with or without 4 | modification, are permitted provided that the following conditions are 5 | met: 6 | 7 | * Redistributions of source code must retain the above copyright 8 | notice, this list of conditions and the following disclaimer. 9 | 10 | * Redistributions in binary form must reproduce the above copyright 11 | notice, this list of conditions and the following disclaimer in 12 | the documentation and/or other materials provided with the 13 | distribution. 14 | 15 | This software is provided by the copyright holders "as is" and any 16 | express or implied warranties, including, but not limited to, the 17 | implied warranties of merchantability and fitness for a particular 18 | purpose are disclaimed. In no event shall the copyright holders be 19 | liable for any direct, indirect, incidental, special, exemplary, or 20 | consequential damages (including, but not limited to, procurement of 21 | substitute goods or services; loss of use, data, or profits; or 22 | business interruption) however caused and on any theory of liability, 23 | whether in contract, strict liability, or tort (including negligence 24 | or otherwise) arising in any way out of the use of this software, even 25 | if advised of the possibility of such damage. 26 | -------------------------------------------------------------------------------- /Text/PrettyPrint/ANSI/Example.hs: -------------------------------------------------------------------------------- 1 | module Main (main) where 2 | 3 | import Text.PrettyPrint.ANSI.Leijen 4 | 5 | import System.IO 6 | 7 | 8 | main :: IO () 9 | main = do 10 | -- Going directly to the console is portable across Unix and Windows... 11 | putDoc $ red (text "Red") <> comma <+> white (text "white") <+> text "and" <+> blue (text "blue") <> char '!' <> linebreak 12 | putDoc $ blue (text "Nested" <+> dullyellow (text "colors") <+> text "example") <> linebreak 13 | hPutDoc stdout $ onred (text "Red") <> comma <+> onwhite (text "white") <+> text "and" <+> onblue (text "blue") <> char '!' <> linebreak 14 | hPutDoc stdout $ onblue (text "Nested" <+> ondullyellow (text "colors") <+> text "example") <> linebreak 15 | 16 | -- ...but going via a string will only preserve formatting information information on Unix 17 | putStr $ show $ green (text "I will be green on Unix but uncolored on Windows") <> linebreak 18 | 19 | -- Let's see some non-color formatting: 20 | putDoc $ text "We can do" <+> bold (text "boldness") <> text ", if your terminal supports it, and even perhaps" <+> underline (text "underlining") <> linebreak 21 | 22 | -- Just a little test of the formatting removal: 23 | putDoc $ text "There is a handy utility called 'plain' to" <+> plain (bold $ text "remove formatting") <+> 24 | plain (text "if you need to e.g. support" <+> red (text "non-ANSI") <+> text "terminals") -------------------------------------------------------------------------------- /release: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | # 3 | 4 | echo "Have you updated the version number? Type 'yes' if you have!" 5 | read version_response 6 | 7 | if [ "$version_response" != "yes" ]; then 8 | echo "Go and update the version number" 9 | exit 1 10 | fi 11 | 12 | sdist_output=`runghc Setup.lhs sdist` 13 | 14 | if [ "$?" != "0" ]; then 15 | echo "Cabal sdist failed, aborting" 16 | exit 1 17 | fi 18 | 19 | # Want to find a line like: 20 | # Source tarball created: dist/ansi-terminal-0.1.tar.gz 21 | 22 | # Test this with: 23 | # runghc Setup.lhs sdist | grep ... 24 | filename=`echo $sdist_output | sed 's/.*Source tarball created: \([^ ]*\).*/\1/'` 25 | echo "Filename: $filename" 26 | 27 | if [ "$filename" = "$sdist_output" ]; then 28 | echo "Could not find filename, aborting" 29 | exit 1 30 | fi 31 | 32 | # Test this with: 33 | # echo dist/ansi-terminal-0.1.tar.gz | sed ... 34 | version=`echo $filename | sed 's/^[^0-9]*\([0-9\.]*\).tar.gz$/\1/'` 35 | echo "Version: $version" 36 | 37 | if [ "$version" = "$filename" ]; then 38 | echo "Could not find version, aborting" 39 | exit 1 40 | fi 41 | 42 | echo "This is your last chance to abort! I'm going to upload in 10 seconds" 43 | sleep 10 44 | 45 | git tag "v$version" 46 | 47 | if [ "$?" != "0" ]; then 48 | echo "Git tag failed, aborting" 49 | exit 1 50 | fi 51 | 52 | # You need to have stored your Hackage username and password as directed by cabal-upload 53 | # I use -v3 because otherwise the error messages can be cryptic :-) 54 | cabal upload -v3 $filename 55 | 56 | if [ "$?" != "0" ]; then 57 | echo "Hackage upload failed, aborting" 58 | exit 1 59 | fi 60 | 61 | # Success! 62 | exit 0 -------------------------------------------------------------------------------- /ansi-wl-pprint.cabal: -------------------------------------------------------------------------------- 1 | Name: ansi-wl-pprint 2 | Version: 0.6.7 3 | Cabal-Version: >= 1.2 4 | Category: User Interfaces, Text 5 | Synopsis: The Wadler/Leijen Pretty Printer for colored ANSI terminal output 6 | Description: This is a pretty printing library based on Wadler's paper "A Prettier Printer". It has been enhanced with support for ANSI terminal colored output using the ansi-terminal package. 7 | License: BSD3 8 | License-File: LICENSE 9 | Extra-Source-Files: README.textile 10 | Author: Daan Leijen, Max Bolingbroke 11 | Maintainer: batterseapower@hotmail.com 12 | Homepage: http://github.com/batterseapower/ansi-wl-pprint 13 | Build-Type: Simple 14 | 15 | Flag NewBase 16 | Description: Choose the new smaller, split-up base package with 6.10 17 | Default: True 18 | 19 | Flag Example 20 | Description: Build the example application 21 | Default: False 22 | 23 | 24 | Library 25 | Exposed-Modules: Text.PrettyPrint.ANSI.Leijen 26 | Ghc-Options: -Wall -fno-warn-name-shadowing -fno-warn-unused-matches 27 | 28 | Build-Depends: ansi-terminal >= 0.4.0 && < 0.7 29 | if flag(newbase) 30 | Build-Depends: base >= 3 && < 5 31 | else 32 | Build-Depends: base < 3 33 | 34 | Executable ansi-wl-pprint-example 35 | Main-Is: Text/PrettyPrint/ANSI/Example.hs 36 | 37 | Build-Depends: ansi-terminal >= 0.4.0 && < 0.7 38 | if flag(newbase) 39 | Build-Depends: base >= 3 && < 5 40 | else 41 | Build-Depends: base < 3 42 | 43 | if !flag(example) 44 | Buildable: False 45 | -------------------------------------------------------------------------------- /Text/PrettyPrint/ANSI/Leijen.hs: -------------------------------------------------------------------------------- 1 | ----------------------------------------------------------------------------- 2 | -- | 3 | -- Module : Text.PrettyPrint.ANSI.Leijen 4 | -- Copyright : Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan 5 | -- Max Bolingbroke (c) 2008, http://blog.omega-prime.co.uk 6 | -- License : BSD-style (see the file LICENSE) 7 | -- 8 | -- Maintainer : batterseapower@hotmail.com 9 | -- Stability : provisional 10 | -- Portability : portable 11 | -- 12 | -- Pretty print module based on Philip Wadler's \"prettier printer\" 13 | -- 14 | -- @ 15 | -- \"A prettier printer\" 16 | -- Draft paper, April 1997, revised March 1998. 17 | -- 18 | -- @ 19 | -- 20 | -- PPrint is an implementation of the pretty printing combinators 21 | -- described by Philip Wadler (1997). In their bare essence, the 22 | -- combinators of Wadler are not expressive enough to describe some 23 | -- commonly occurring layouts. The PPrint library adds new primitives 24 | -- to describe these layouts and works well in practice. 25 | -- 26 | -- The library is based on a single way to concatenate documents, 27 | -- which is associative and has both a left and right unit. This 28 | -- simple design leads to an efficient and short implementation. The 29 | -- simplicity is reflected in the predictable behaviour of the 30 | -- combinators which make them easy to use in practice. 31 | -- 32 | -- A thorough description of the primitive combinators and their 33 | -- implementation can be found in Philip Wadler's paper 34 | -- (1997). Additions and the main differences with his original paper 35 | -- are: 36 | -- 37 | -- * The nil document is called empty. 38 | -- 39 | -- * The above combinator is called '<$>'. The operator '' is used 40 | -- for soft line breaks. 41 | -- 42 | -- * There are three new primitives: 'align', 'fill' and 43 | -- 'fillBreak'. These are very useful in practice. 44 | -- 45 | -- * Lots of other useful combinators, like 'fillSep' and 'list'. 46 | -- 47 | -- * There are two renderers, 'renderPretty' for pretty printing and 48 | -- 'renderCompact' for compact output. The pretty printing algorithm 49 | -- also uses a ribbon-width now for even prettier output. 50 | -- 51 | -- * There are two displayers, 'displayS' for strings and 'displayIO' for 52 | -- file based output. 53 | -- 54 | -- * There is a 'Pretty' class. 55 | -- 56 | -- * The implementation uses optimised representations and strictness 57 | -- annotations. 58 | -- 59 | -- Full documentation for the original wl-pprint library available at 60 | -- . 61 | -- 62 | -- The library has been extended to allow formatting text for output 63 | -- to ANSI style consoles. New combinators allow: 64 | -- 65 | -- * Control of foreground and background color of text 66 | -- 67 | -- * The abliity to make parts of the text bold or underlined 68 | -- 69 | -- This functionality is, as far as possible, portable across platforms 70 | -- with their varying terminals. However, one thing to be particularly 71 | -- wary of is that console colors will not be displayed on Windows unless 72 | -- the 'Doc' value is output using the 'putDoc' function or one of it's 73 | -- friends. Rendering the 'Doc' to a 'String' and then outputing /that/ 74 | -- will only work on Unix-style operating systems. 75 | ----------------------------------------------------------- 76 | module Text.PrettyPrint.ANSI.Leijen ( 77 | -- * Documents 78 | Doc, putDoc, hPutDoc, 79 | 80 | -- * Basic combinators 81 | empty, char, text, (<>), nest, line, linebreak, group, softline, 82 | softbreak, hardline, flatAlt, renderSmart, 83 | 84 | -- * Alignment 85 | -- 86 | -- The combinators in this section can not be described by Wadler's 87 | -- original combinators. They align their output relative to the 88 | -- current output position - in contrast to @nest@ which always 89 | -- aligns to the current nesting level. This deprives these 90 | -- combinators from being \`optimal\'. In practice however they 91 | -- prove to be very useful. The combinators in this section should 92 | -- be used with care, since they are more expensive than the other 93 | -- combinators. For example, @align@ shouldn't be used to pretty 94 | -- print all top-level declarations of a language, but using @hang@ 95 | -- for let expressions is fine. 96 | align, hang, indent, encloseSep, list, tupled, semiBraces, 97 | 98 | -- * Operators 99 | (<+>), (<$>), (), (<$$>), (), 100 | 101 | -- * List combinators 102 | hsep, vsep, fillSep, sep, hcat, vcat, fillCat, cat, punctuate, 103 | 104 | -- * Fillers 105 | fill, fillBreak, 106 | 107 | -- * Bracketing combinators 108 | enclose, squotes, dquotes, parens, angles, braces, brackets, 109 | 110 | -- * Character documents 111 | lparen, rparen, langle, rangle, lbrace, rbrace, lbracket, rbracket, 112 | squote, dquote, semi, colon, comma, space, dot, backslash, equals, 113 | 114 | -- * Colorisation combinators 115 | black, red, green, yellow, blue, magenta, cyan, white, 116 | dullblack, dullred, dullgreen, dullyellow, dullblue, dullmagenta, dullcyan, dullwhite, 117 | onblack, onred, ongreen, onyellow, onblue, onmagenta, oncyan, onwhite, 118 | ondullblack, ondullred, ondullgreen, ondullyellow, ondullblue, ondullmagenta, ondullcyan, ondullwhite, 119 | 120 | -- * Emboldening combinators 121 | bold, debold, 122 | 123 | -- * Underlining combinators 124 | underline, deunderline, 125 | 126 | -- * Removing formatting 127 | plain, 128 | 129 | -- * Primitive type documents 130 | string, int, integer, float, double, rational, 131 | 132 | -- * Pretty class 133 | Pretty(..), 134 | 135 | -- * Rendering 136 | SimpleDoc(..), renderPretty, renderCompact, displayS, displayIO 137 | 138 | -- * Undocumented 139 | , bool 140 | 141 | , column, columns, nesting, width 142 | 143 | ) where 144 | 145 | import System.IO (Handle,hPutStr,hPutChar,stdout) 146 | 147 | import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), 148 | Underlining(..), ConsoleIntensity(..), 149 | SGR(..), hSetSGR, setSGRCode) 150 | 151 | import Data.String (IsString(..)) 152 | import Data.Maybe (catMaybes) 153 | import Data.Monoid (Monoid, mappend, mconcat, mempty) 154 | 155 | 156 | infixr 5 ,,<$>,<$$> 157 | infixr 6 <>,<+> 158 | 159 | 160 | ----------------------------------------------------------- 161 | -- list, tupled and semiBraces pretty print a list of 162 | -- documents either horizontally or vertically aligned. 163 | ----------------------------------------------------------- 164 | 165 | 166 | -- | The document @(list xs)@ comma separates the documents @xs@ and 167 | -- encloses them in square brackets. The documents are rendered 168 | -- horizontally if that fits the page. Otherwise they are aligned 169 | -- vertically. All comma separators are put in front of the elements. 170 | list :: [Doc] -> Doc 171 | list = encloseSep lbracket rbracket comma 172 | 173 | -- | The document @(tupled xs)@ comma separates the documents @xs@ and 174 | -- encloses them in parenthesis. The documents are rendered 175 | -- horizontally if that fits the page. Otherwise they are aligned 176 | -- vertically. All comma separators are put in front of the elements. 177 | tupled :: [Doc] -> Doc 178 | tupled = encloseSep lparen rparen comma 179 | 180 | 181 | -- | The document @(semiBraces xs)@ separates the documents @xs@ with 182 | -- semi colons and encloses them in braces. The documents are rendered 183 | -- horizontally if that fits the page. Otherwise they are aligned 184 | -- vertically. All semi colons are put in front of the elements. 185 | semiBraces :: [Doc] -> Doc 186 | semiBraces = encloseSep lbrace rbrace semi 187 | 188 | -- | The document @(encloseSep l r sep xs)@ concatenates the documents 189 | -- @xs@ separated by @sep@ and encloses the resulting document by @l@ 190 | -- and @r@. The documents are rendered horizontally if that fits the 191 | -- page. Otherwise they are aligned vertically. All separators are put 192 | -- in front of the elements. For example, the combinator 'list' can be 193 | -- defined with @encloseSep@: 194 | -- 195 | -- > list xs = encloseSep lbracket rbracket comma xs 196 | -- > test = text "list" <+> (list (map int [10,200,3000])) 197 | -- 198 | -- Which is layed out with a page width of 20 as: 199 | -- 200 | -- @ 201 | -- list [10,200,3000] 202 | -- @ 203 | -- 204 | -- But when the page width is 15, it is layed out as: 205 | -- 206 | -- @ 207 | -- list [10 208 | -- ,200 209 | -- ,3000] 210 | -- @ 211 | encloseSep :: Doc -> Doc -> Doc -> [Doc] -> Doc 212 | encloseSep left right sep ds 213 | = case ds of 214 | [] -> left <> right 215 | [d] -> left <> d <> right 216 | _ -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right) 217 | 218 | 219 | ----------------------------------------------------------- 220 | -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn] 221 | ----------------------------------------------------------- 222 | 223 | 224 | -- | @(punctuate p xs)@ concatenates all documents in @xs@ with 225 | -- document @p@ except for the last document. 226 | -- 227 | -- > someText = map text ["words","in","a","tuple"] 228 | -- > test = parens (align (cat (punctuate comma someText))) 229 | -- 230 | -- This is layed out on a page width of 20 as: 231 | -- 232 | -- @ 233 | -- (words,in,a,tuple) 234 | -- @ 235 | -- 236 | -- But when the page width is 15, it is layed out as: 237 | -- 238 | -- @ 239 | -- (words, 240 | -- in, 241 | -- a, 242 | -- tuple) 243 | -- @ 244 | -- 245 | -- (If you want put the commas in front of their elements instead of 246 | -- at the end, you should use 'tupled' or, in general, 'encloseSep'.) 247 | punctuate :: Doc -> [Doc] -> [Doc] 248 | punctuate p [] = [] 249 | punctuate p [d] = [d] 250 | punctuate p (d:ds) = (d <> p) : punctuate p ds 251 | 252 | 253 | ----------------------------------------------------------- 254 | -- high-level combinators 255 | ----------------------------------------------------------- 256 | 257 | 258 | -- | The document @(sep xs)@ concatenates all documents @xs@ either 259 | -- horizontally with @(\<+\>)@, if it fits the page, or vertically with 260 | -- @(\<$\>)@. 261 | -- 262 | -- > sep xs = group (vsep xs) 263 | sep :: [Doc] -> Doc 264 | sep = group . vsep 265 | 266 | -- | The document @(fillSep xs)@ concatenates documents @xs@ 267 | -- horizontally with @(\<+\>)@ as long as its fits the page, than 268 | -- inserts a @line@ and continues doing that for all documents in 269 | -- @xs@. 270 | -- 271 | -- > fillSep xs = foldr (\<\/\>) empty xs 272 | fillSep :: [Doc] -> Doc 273 | fillSep = fold () 274 | 275 | -- | The document @(hsep xs)@ concatenates all documents @xs@ 276 | -- horizontally with @(\<+\>)@. 277 | hsep :: [Doc] -> Doc 278 | hsep = fold (<+>) 279 | 280 | 281 | -- | The document @(vsep xs)@ concatenates all documents @xs@ 282 | -- vertically with @(\<$\>)@. If a 'group' undoes the line breaks 283 | -- inserted by @vsep@, all documents are separated with a space. 284 | -- 285 | -- > someText = map text (words ("text to lay out")) 286 | -- > 287 | -- > test = text "some" <+> vsep someText 288 | -- 289 | -- This is layed out as: 290 | -- 291 | -- @ 292 | -- some text 293 | -- to 294 | -- lay 295 | -- out 296 | -- @ 297 | -- 298 | -- The 'align' combinator can be used to align the documents under 299 | -- their first element 300 | -- 301 | -- > test = text "some" <+> align (vsep someText) 302 | -- 303 | -- Which is printed as: 304 | -- 305 | -- @ 306 | -- some text 307 | -- to 308 | -- lay 309 | -- out 310 | -- @ 311 | vsep :: [Doc] -> Doc 312 | vsep = fold (<$>) 313 | 314 | -- | The document @(cat xs)@ concatenates all documents @xs@ either 315 | -- horizontally with @(\<\>)@, if it fits the page, or vertically with 316 | -- @(\<$$\>)@. 317 | -- 318 | -- > cat xs = group (vcat xs) 319 | cat :: [Doc] -> Doc 320 | cat = group . vcat 321 | 322 | -- | The document @(fillCat xs)@ concatenates documents @xs@ 323 | -- horizontally with @(\<\>)@ as long as its fits the page, than inserts 324 | -- a @linebreak@ and continues doing that for all documents in @xs@. 325 | -- 326 | -- > fillCat xs = foldr (\<\/\/\>) empty xs 327 | fillCat :: [Doc] -> Doc 328 | fillCat = fold () 329 | 330 | -- | The document @(hcat xs)@ concatenates all documents @xs@ 331 | -- horizontally with @(\<\>)@. 332 | hcat :: [Doc] -> Doc 333 | hcat = fold (<>) 334 | 335 | -- | The document @(vcat xs)@ concatenates all documents @xs@ 336 | -- vertically with @(\<$$\>)@. If a 'group' undoes the line breaks 337 | -- inserted by @vcat@, all documents are directly concatenated. 338 | vcat :: [Doc] -> Doc 339 | vcat = fold (<$$>) 340 | 341 | fold :: (Doc -> Doc -> Doc) -> [Doc] -> Doc 342 | fold f [] = empty 343 | fold f ds = foldr1 f ds 344 | 345 | -- | The document @(x \<\> y)@ concatenates document @x@ and document 346 | -- @y@. It is an associative operation having 'empty' as a left and 347 | -- right unit. (infixr 6) 348 | (<>) :: Doc -> Doc -> Doc 349 | x <> y = x `beside` y 350 | 351 | -- | The document @(x \<+\> y)@ concatenates document @x@ and @y@ with a 352 | -- @space@ in between. (infixr 6) 353 | (<+>) :: Doc -> Doc -> Doc 354 | x <+> y = x <> space <> y 355 | 356 | -- | The document @(x \<\/\> y)@ concatenates document @x@ and @y@ with a 357 | -- 'softline' in between. This effectively puts @x@ and @y@ either 358 | -- next to each other (with a @space@ in between) or underneath each 359 | -- other. (infixr 5) 360 | () :: Doc -> Doc -> Doc 361 | x y = x <> softline <> y 362 | 363 | -- | The document @(x \<\/\/\> y)@ concatenates document @x@ and @y@ with 364 | -- a 'softbreak' in between. This effectively puts @x@ and @y@ either 365 | -- right next to each other or underneath each other. (infixr 5) 366 | () :: Doc -> Doc -> Doc 367 | x y = x <> softbreak <> y 368 | 369 | -- | The document @(x \<$\> y)@ concatenates document @x@ and @y@ with a 370 | -- 'line' in between. (infixr 5) 371 | (<$>) :: Doc -> Doc -> Doc 372 | x <$> y = x <> line <> y 373 | 374 | -- | The document @(x \<$$\> y)@ concatenates document @x@ and @y@ with 375 | -- a @linebreak@ in between. (infixr 5) 376 | (<$$>) :: Doc -> Doc -> Doc 377 | x <$$> y = x <> linebreak <> y 378 | 379 | -- | The document @softline@ behaves like 'space' if the resulting 380 | -- output fits the page, otherwise it behaves like 'line'. 381 | -- 382 | -- > softline = group line 383 | softline :: Doc 384 | softline = group line 385 | 386 | -- | The document @softbreak@ behaves like 'empty' if the resulting 387 | -- output fits the page, otherwise it behaves like 'line'. 388 | -- 389 | -- > softbreak = group linebreak 390 | softbreak :: Doc 391 | softbreak = group linebreak 392 | 393 | -- | Document @(squotes x)@ encloses document @x@ with single quotes 394 | -- \"'\". 395 | squotes :: Doc -> Doc 396 | squotes = enclose squote squote 397 | 398 | -- | Document @(dquotes x)@ encloses document @x@ with double quotes 399 | -- '\"'. 400 | dquotes :: Doc -> Doc 401 | dquotes = enclose dquote dquote 402 | 403 | -- | Document @(braces x)@ encloses document @x@ in braces, \"{\" and 404 | -- \"}\". 405 | braces :: Doc -> Doc 406 | braces = enclose lbrace rbrace 407 | 408 | -- | Document @(parens x)@ encloses document @x@ in parenthesis, \"(\" 409 | -- and \")\". 410 | parens :: Doc -> Doc 411 | parens = enclose lparen rparen 412 | 413 | -- | Document @(angles x)@ encloses document @x@ in angles, \"\<\" and 414 | -- \"\>\". 415 | angles :: Doc -> Doc 416 | angles = enclose langle rangle 417 | 418 | -- | Document @(brackets x)@ encloses document @x@ in square brackets, 419 | -- \"[\" and \"]\". 420 | brackets :: Doc -> Doc 421 | brackets = enclose lbracket rbracket 422 | 423 | -- | The document @(enclose l r x)@ encloses document @x@ between 424 | -- documents @l@ and @r@ using @(\<\>)@. 425 | -- 426 | -- > enclose l r x = l <> x <> r 427 | enclose :: Doc -> Doc -> Doc -> Doc 428 | enclose l r x = l <> x <> r 429 | 430 | -- | The document @lparen@ contains a left parenthesis, \"(\". 431 | lparen :: Doc 432 | lparen = char '(' 433 | -- | The document @rparen@ contains a right parenthesis, \")\". 434 | rparen :: Doc 435 | rparen = char ')' 436 | -- | The document @langle@ contains a left angle, \"\<\". 437 | langle :: Doc 438 | langle = char '<' 439 | -- | The document @rangle@ contains a right angle, \">\". 440 | rangle :: Doc 441 | rangle = char '>' 442 | -- | The document @lbrace@ contains a left brace, \"{\". 443 | lbrace :: Doc 444 | lbrace = char '{' 445 | -- | The document @rbrace@ contains a right brace, \"}\". 446 | rbrace :: Doc 447 | rbrace = char '}' 448 | -- | The document @lbracket@ contains a left square bracket, \"[\". 449 | lbracket :: Doc 450 | lbracket = char '[' 451 | -- | The document @rbracket@ contains a right square bracket, \"]\". 452 | rbracket :: Doc 453 | rbracket = char ']' 454 | 455 | 456 | -- | The document @squote@ contains a single quote, \"'\". 457 | squote :: Doc 458 | squote = char '\'' 459 | -- | The document @dquote@ contains a double quote, '\"'. 460 | dquote :: Doc 461 | dquote = char '"' 462 | -- | The document @semi@ contains a semi colon, \";\". 463 | semi :: Doc 464 | semi = char ';' 465 | -- | The document @colon@ contains a colon, \":\". 466 | colon :: Doc 467 | colon = char ':' 468 | -- | The document @comma@ contains a comma, \",\". 469 | comma :: Doc 470 | comma = char ',' 471 | -- | The document @space@ contains a single space, \" \". 472 | -- 473 | -- > x <+> y = x <> space <> y 474 | space :: Doc 475 | space = char ' ' 476 | -- | The document @dot@ contains a single dot, \".\". 477 | dot :: Doc 478 | dot = char '.' 479 | -- | The document @backslash@ contains a back slash, \"\\\". 480 | backslash :: Doc 481 | backslash = char '\\' 482 | -- | The document @equals@ contains an equal sign, \"=\". 483 | equals :: Doc 484 | equals = char '=' 485 | 486 | 487 | ----------------------------------------------------------- 488 | -- Combinators for prelude types 489 | ----------------------------------------------------------- 490 | 491 | -- string is like "text" but replaces '\n' by "line" 492 | 493 | -- | The document @(string s)@ concatenates all characters in @s@ 494 | -- using @line@ for newline characters and @char@ for all other 495 | -- characters. It is used instead of 'text' whenever the text contains 496 | -- newline characters. 497 | string :: String -> Doc 498 | string "" = empty 499 | string ('\n':s) = line <> string s 500 | string s = case (span (/='\n') s) of 501 | (xs,ys) -> text xs <> string ys 502 | 503 | bool :: Bool -> Doc 504 | bool b = text (show b) 505 | 506 | -- | The document @(int i)@ shows the literal integer @i@ using 507 | -- 'text'. 508 | int :: Int -> Doc 509 | int i = text (show i) 510 | 511 | -- | The document @(integer i)@ shows the literal integer @i@ using 512 | -- 'text'. 513 | integer :: Integer -> Doc 514 | integer i = text (show i) 515 | 516 | -- | The document @(float f)@ shows the literal float @f@ using 517 | -- 'text'. 518 | float :: Float -> Doc 519 | float f = text (show f) 520 | 521 | -- | The document @(double d)@ shows the literal double @d@ using 522 | -- 'text'. 523 | double :: Double -> Doc 524 | double d = text (show d) 525 | 526 | -- | The document @(rational r)@ shows the literal rational @r@ using 527 | -- 'text'. 528 | rational :: Rational -> Doc 529 | rational r = text (show r) 530 | 531 | 532 | ----------------------------------------------------------- 533 | -- overloading "pretty" 534 | ----------------------------------------------------------- 535 | 536 | -- | The member @prettyList@ is only used to define the @instance Pretty 537 | -- a => Pretty [a]@. In normal circumstances only the @pretty@ function 538 | -- is used. 539 | class Pretty a where 540 | pretty :: a -> Doc 541 | prettyList :: [a] -> Doc 542 | prettyList = list . map pretty 543 | 544 | instance Pretty a => Pretty [a] where 545 | pretty = prettyList 546 | 547 | instance Pretty Doc where 548 | pretty = id 549 | 550 | instance Pretty () where 551 | pretty () = text "()" 552 | 553 | instance Pretty Bool where 554 | pretty b = bool b 555 | 556 | instance Pretty Char where 557 | pretty c = char c 558 | prettyList s = string s 559 | 560 | instance Pretty Int where 561 | pretty i = int i 562 | 563 | instance Pretty Integer where 564 | pretty i = integer i 565 | 566 | instance Pretty Float where 567 | pretty f = float f 568 | 569 | instance Pretty Double where 570 | pretty d = double d 571 | 572 | 573 | --instance Pretty Rational where 574 | -- pretty r = rational r 575 | 576 | instance (Pretty a,Pretty b) => Pretty (a,b) where 577 | pretty (x,y) = tupled [pretty x, pretty y] 578 | 579 | instance (Pretty a,Pretty b,Pretty c) => Pretty (a,b,c) where 580 | pretty (x,y,z)= tupled [pretty x, pretty y, pretty z] 581 | 582 | instance Pretty a => Pretty (Maybe a) where 583 | pretty Nothing = empty 584 | pretty (Just x) = pretty x 585 | 586 | 587 | 588 | ----------------------------------------------------------- 589 | -- semi primitive: fill and fillBreak 590 | ----------------------------------------------------------- 591 | 592 | -- | The document @(fillBreak i x)@ first renders document @x@. It 593 | -- than appends @space@s until the width is equal to @i@. If the 594 | -- width of @x@ is already larger than @i@, the nesting level is 595 | -- increased by @i@ and a @line@ is appended. When we redefine @ptype@ 596 | -- in the previous example to use @fillBreak@, we get a useful 597 | -- variation of the previous output: 598 | -- 599 | -- > ptype (name,tp) 600 | -- > = fillBreak 6 (text name) <+> text "::" <+> text tp 601 | -- 602 | -- The output will now be: 603 | -- 604 | -- @ 605 | -- let empty :: Doc 606 | -- nest :: Int -> Doc -> Doc 607 | -- linebreak 608 | -- :: Doc 609 | -- @ 610 | fillBreak :: Int -> Doc -> Doc 611 | fillBreak f x = width x (\w -> 612 | if (w > f) then nest f linebreak 613 | else text (spaces (f - w))) 614 | 615 | 616 | -- | The document @(fill i x)@ renders document @x@. It than appends 617 | -- @space@s until the width is equal to @i@. If the width of @x@ is 618 | -- already larger, nothing is appended. This combinator is quite 619 | -- useful in practice to output a list of bindings. The following 620 | -- example demonstrates this. 621 | -- 622 | -- > types = [("empty","Doc") 623 | -- > ,("nest","Int -> Doc -> Doc") 624 | -- > ,("linebreak","Doc")] 625 | -- > 626 | -- > ptype (name,tp) 627 | -- > = fill 6 (text name) <+> text "::" <+> text tp 628 | -- > 629 | -- > test = text "let" <+> align (vcat (map ptype types)) 630 | -- 631 | -- Which is layed out as: 632 | -- 633 | -- @ 634 | -- let empty :: Doc 635 | -- nest :: Int -> Doc -> Doc 636 | -- linebreak :: Doc 637 | -- @ 638 | fill :: Int -> Doc -> Doc 639 | fill f d = width d (\w -> 640 | if (w >= f) then empty 641 | else text (spaces (f - w))) 642 | 643 | width :: Doc -> (Int -> Doc) -> Doc 644 | width d f = column (\k1 -> d <> column (\k2 -> f (k2 - k1))) 645 | 646 | 647 | ----------------------------------------------------------- 648 | -- semi primitive: Alignment and indentation 649 | ----------------------------------------------------------- 650 | 651 | -- | The document @(indent i x)@ indents document @x@ with @i@ spaces. 652 | -- 653 | -- > test = indent 4 (fillSep (map text 654 | -- > (words "the indent combinator indents these words !"))) 655 | -- 656 | -- Which lays out with a page width of 20 as: 657 | -- 658 | -- @ 659 | -- the indent 660 | -- combinator 661 | -- indents these 662 | -- words ! 663 | -- @ 664 | indent :: Int -> Doc -> Doc 665 | indent i d = hang i (text (spaces i) <> d) 666 | 667 | -- | The hang combinator implements hanging indentation. The document 668 | -- @(hang i x)@ renders document @x@ with a nesting level set to the 669 | -- current column plus @i@. The following example uses hanging 670 | -- indentation for some text: 671 | -- 672 | -- > test = hang 4 (fillSep (map text 673 | -- > (words "the hang combinator indents these words !"))) 674 | -- 675 | -- Which lays out on a page with a width of 20 characters as: 676 | -- 677 | -- @ 678 | -- the hang combinator 679 | -- indents these 680 | -- words ! 681 | -- @ 682 | -- 683 | -- The @hang@ combinator is implemented as: 684 | -- 685 | -- > hang i x = align (nest i x) 686 | hang :: Int -> Doc -> Doc 687 | hang i d = align (nest i d) 688 | 689 | -- | The document @(align x)@ renders document @x@ with the nesting 690 | -- level set to the current column. It is used for example to 691 | -- implement 'hang'. 692 | -- 693 | -- As an example, we will put a document right above another one, 694 | -- regardless of the current nesting level: 695 | -- 696 | -- > x $$ y = align (x <$> y) 697 | -- 698 | -- > test = text "hi" <+> (text "nice" $$ text "world") 699 | -- 700 | -- which will be layed out as: 701 | -- 702 | -- @ 703 | -- hi nice 704 | -- world 705 | -- @ 706 | align :: Doc -> Doc 707 | align d = column (\k -> 708 | nesting (\i -> nest (k - i) d)) --nesting might be negative :-) 709 | 710 | 711 | 712 | ----------------------------------------------------------- 713 | -- Primitives 714 | ----------------------------------------------------------- 715 | 716 | -- | The abstract data type @Doc@ represents pretty documents. 717 | -- 718 | -- @Doc@ is an instance of the 'Show' class. @(show doc)@ pretty 719 | -- prints document @doc@ with a page width of 100 characters and a 720 | -- ribbon width of 40 characters. 721 | -- 722 | -- > show (text "hello" <$> text "world") 723 | -- 724 | -- Which would return the string \"hello\\nworld\", i.e. 725 | -- 726 | -- @ 727 | -- hello 728 | -- world 729 | -- @ 730 | data Doc = Fail 731 | | Empty 732 | | Char Char -- invariant: char is not '\n' 733 | | Text !Int String -- invariant: text doesn't contain '\n' 734 | | Line 735 | | FlatAlt Doc Doc -- Render the first doc, but when 736 | -- flattened, render the second. 737 | | Cat Doc Doc 738 | | Nest !Int Doc 739 | | Union Doc Doc -- invariant: first lines of first doc longer than the first lines of the second doc 740 | | Column (Int -> Doc) 741 | | Columns (Maybe Int -> Doc) 742 | | Nesting (Int -> Doc) 743 | | Color ConsoleLayer ColorIntensity -- Introduces coloring /around/ the embedded document 744 | Color Doc 745 | | Intensify ConsoleIntensity Doc 746 | | Italicize Bool Doc 747 | | Underline Underlining Doc 748 | | RestoreFormat (Maybe (ColorIntensity, Color)) -- Only used during the rendered phase, to signal a SGR should be issued to restore the terminal formatting. 749 | (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). 750 | (Maybe ConsoleIntensity) -- Intensity to revert to. 751 | (Maybe Bool) -- Italicization to revert to. 752 | (Maybe Underlining) -- Underlining to revert to. 753 | 754 | 755 | -- | The data type @SimpleDoc@ represents rendered documents and is 756 | -- used by the display functions. 757 | -- 758 | -- The @Int@ in @SText@ contains the length of the string. The @Int@ 759 | -- in @SLine@ contains the indentation for that line. The library 760 | -- provides two default display functions 'displayS' and 761 | -- 'displayIO'. You can provide your own display function by writing a 762 | -- function from a @SimpleDoc@ to your own output format. 763 | data SimpleDoc = SFail 764 | | SEmpty 765 | | SChar Char SimpleDoc 766 | | SText !Int String SimpleDoc 767 | | SLine !Int SimpleDoc 768 | | SSGR [SGR] SimpleDoc 769 | 770 | 771 | -- MCB: Not in the wl-pprint package that we forked from. I added this when the "pretty" package 772 | -- from base gained a Monoid instance (): 773 | instance Monoid Doc where 774 | mempty = empty 775 | mappend = (<>) 776 | mconcat = hcat 777 | 778 | -- MCB: also added when "pretty" got the corresponding instances: 779 | instance IsString Doc where 780 | fromString = text 781 | 782 | 783 | -- | The empty document is, indeed, empty. Although @empty@ has no 784 | -- content, it does have a \'height\' of 1 and behaves exactly like 785 | -- @(text \"\")@ (and is therefore not a unit of @\<$\>@). 786 | empty :: Doc 787 | empty = Empty 788 | 789 | -- | The document @(char c)@ contains the literal character @c@. The 790 | -- character shouldn't be a newline (@'\n'@), the function 'line' 791 | -- should be used for line breaks. 792 | char :: Char -> Doc 793 | char '\n' = line 794 | char c = Char c 795 | 796 | -- | The document @(text s)@ contains the literal string @s@. The 797 | -- string shouldn't contain any newline (@'\n'@) characters. If the 798 | -- string contains newline characters, the function 'string' should be 799 | -- used. 800 | text :: String -> Doc 801 | text "" = Empty 802 | text s = Text (length s) s 803 | 804 | -- | The @line@ document advances to the next line and indents to the 805 | -- current nesting level. Document @line@ behaves like @(text \" \")@ 806 | -- if the line break is undone by 'group'. 807 | line :: Doc 808 | line = FlatAlt Line space 809 | 810 | -- | The @linebreak@ document advances to the next line and indents to 811 | -- the current nesting level. Document @linebreak@ behaves like 812 | -- 'empty' if the line break is undone by 'group'. 813 | linebreak :: Doc 814 | linebreak = FlatAlt Line empty 815 | 816 | -- | A linebreak that will never be flattened; it is guaranteed to render 817 | -- as a newline. 818 | hardline :: Doc 819 | hardline = Line 820 | 821 | beside :: Doc -> Doc -> Doc 822 | beside x y = Cat x y 823 | 824 | -- | The document @(nest i x)@ renders document @x@ with the current 825 | -- indentation level increased by i (See also 'hang', 'align' and 826 | -- 'indent'). 827 | -- 828 | -- > nest 2 (text "hello" <$> text "world") <$> text "!" 829 | -- 830 | -- outputs as: 831 | -- 832 | -- @ 833 | -- hello 834 | -- world 835 | -- ! 836 | -- @ 837 | nest :: Int -> Doc -> Doc 838 | nest i x = Nest i x 839 | 840 | column, nesting :: (Int -> Doc) -> Doc 841 | column f = Column f 842 | nesting f = Nesting f 843 | 844 | columns :: (Maybe Int -> Doc) -> Doc 845 | columns f = Columns f 846 | 847 | -- | The @group@ combinator is used to specify alternative 848 | -- layouts. The document @(group x)@ undoes all line breaks in 849 | -- document @x@. The resulting line is added to the current line if 850 | -- that fits the page. Otherwise, the document @x@ is rendered without 851 | -- any changes. 852 | group :: Doc -> Doc 853 | group x = Union (flatten x) x 854 | 855 | -- | A document that is normally rendered as the first argument, but 856 | -- when flattened, is rendered as the second document. 857 | flatAlt :: Doc -> Doc -> Doc 858 | flatAlt = FlatAlt 859 | 860 | flatten :: Doc -> Doc 861 | flatten (FlatAlt x y) = y 862 | flatten (Cat x y) = Cat (flatten x) (flatten y) 863 | flatten (Nest i x) = Nest i (flatten x) 864 | flatten Line = Fail 865 | flatten (Union x y) = flatten x 866 | flatten (Column f) = Column (flatten . f) 867 | flatten (Columns f) = Columns (flatten . f) 868 | flatten (Nesting f) = Nesting (flatten . f) 869 | flatten (Color l i c x) = Color l i c (flatten x) 870 | flatten (Intensify i x) = Intensify i (flatten x) 871 | flatten (Italicize b x) = Italicize b (flatten x) 872 | flatten (Underline u x) = Underline u (flatten x) 873 | flatten other = other --Empty,Char,Text,RestoreFormat 874 | 875 | 876 | ----------------------------------------------------------- 877 | -- Colors 878 | ----------------------------------------------------------- 879 | 880 | -- | Displays a document with the black forecolor 881 | black :: Doc -> Doc 882 | -- | Displays a document with the red forecolor 883 | red :: Doc -> Doc 884 | -- | Displays a document with the green forecolor 885 | green :: Doc -> Doc 886 | -- | Displays a document with the yellow forecolor 887 | yellow :: Doc -> Doc 888 | -- | Displays a document with the blue forecolor 889 | blue :: Doc -> Doc 890 | -- | Displays a document with the magenta forecolor 891 | magenta :: Doc -> Doc 892 | -- | Displays a document with the cyan forecolor 893 | cyan :: Doc -> Doc 894 | -- | Displays a document with the white forecolor 895 | white :: Doc -> Doc 896 | -- | Displays a document with the dull black forecolor 897 | dullblack :: Doc -> Doc 898 | -- | Displays a document with the dull red forecolor 899 | dullred :: Doc -> Doc 900 | -- | Displays a document with the dull green forecolor 901 | dullgreen :: Doc -> Doc 902 | -- | Displays a document with the dull yellow forecolor 903 | dullyellow :: Doc -> Doc 904 | -- | Displays a document with the dull blue forecolor 905 | dullblue :: Doc -> Doc 906 | -- | Displays a document with the dull magenta forecolor 907 | dullmagenta :: Doc -> Doc 908 | -- | Displays a document with the dull cyan forecolor 909 | dullcyan :: Doc -> Doc 910 | -- | Displays a document with the dull white forecolor 911 | dullwhite :: Doc -> Doc 912 | (black, dullblack) = colorFunctions Black 913 | (red, dullred) = colorFunctions Red 914 | (green, dullgreen) = colorFunctions Green 915 | (yellow, dullyellow) = colorFunctions Yellow 916 | (blue, dullblue) = colorFunctions Blue 917 | (magenta, dullmagenta) = colorFunctions Magenta 918 | (cyan, dullcyan) = colorFunctions Cyan 919 | (white, dullwhite) = colorFunctions White 920 | 921 | -- | Displays a document with a forecolor given in the first parameter 922 | color :: Color -> Doc -> Doc 923 | -- | Displays a document with a dull forecolor given in the first parameter 924 | dullcolor :: Color -> Doc -> Doc 925 | color = Color Foreground Vivid 926 | dullcolor = Color Foreground Dull 927 | 928 | colorFunctions :: Color -> (Doc -> Doc, Doc -> Doc) 929 | colorFunctions what = (color what, dullcolor what) 930 | 931 | -- | Displays a document with the black backcolor 932 | onblack :: Doc -> Doc 933 | -- | Displays a document with the red backcolor 934 | onred :: Doc -> Doc 935 | -- | Displays a document with the green backcolor 936 | ongreen :: Doc -> Doc 937 | -- | Displays a document with the yellow backcolor 938 | onyellow :: Doc -> Doc 939 | -- | Displays a document with the blue backcolor 940 | onblue :: Doc -> Doc 941 | -- | Displays a document with the magenta backcolor 942 | onmagenta :: Doc -> Doc 943 | -- | Displays a document with the cyan backcolor 944 | oncyan :: Doc -> Doc 945 | -- | Displays a document with the white backcolor 946 | onwhite :: Doc -> Doc 947 | -- | Displays a document with the dull block backcolor 948 | ondullblack :: Doc -> Doc 949 | -- | Displays a document with the dull red backcolor 950 | ondullred :: Doc -> Doc 951 | -- | Displays a document with the dull green backcolor 952 | ondullgreen :: Doc -> Doc 953 | -- | Displays a document with the dull yellow backcolor 954 | ondullyellow :: Doc -> Doc 955 | -- | Displays a document with the dull blue backcolor 956 | ondullblue :: Doc -> Doc 957 | -- | Displays a document with the dull magenta backcolor 958 | ondullmagenta :: Doc -> Doc 959 | -- | Displays a document with the dull cyan backcolor 960 | ondullcyan :: Doc -> Doc 961 | -- | Displays a document with the dull white backcolor 962 | ondullwhite :: Doc -> Doc 963 | (onblack, ondullblack) = oncolorFunctions Black 964 | (onred, ondullred) = oncolorFunctions Red 965 | (ongreen, ondullgreen) = oncolorFunctions Green 966 | (onyellow, ondullyellow) = oncolorFunctions Yellow 967 | (onblue, ondullblue) = oncolorFunctions Blue 968 | (onmagenta, ondullmagenta) = oncolorFunctions Magenta 969 | (oncyan, ondullcyan) = oncolorFunctions Cyan 970 | (onwhite, ondullwhite) = oncolorFunctions White 971 | 972 | -- | Displays a document with a backcolor given in the first parameter 973 | oncolor :: Color -> Doc -> Doc 974 | -- | Displays a document with a dull backcolor given in the first parameter 975 | ondullcolor :: Color -> Doc -> Doc 976 | oncolor = Color Background Vivid 977 | ondullcolor = Color Background Dull 978 | 979 | oncolorFunctions :: Color -> (Doc -> Doc, Doc -> Doc) 980 | oncolorFunctions what = (oncolor what, ondullcolor what) 981 | 982 | 983 | ----------------------------------------------------------- 984 | -- Console Intensity 985 | ----------------------------------------------------------- 986 | 987 | -- | Displays a document in a heavier font weight 988 | bold :: Doc -> Doc 989 | bold = Intensify BoldIntensity 990 | 991 | -- | Displays a document in the normal font weight 992 | debold :: Doc -> Doc 993 | debold = Intensify NormalIntensity 994 | 995 | -- NB: I don't support FaintIntensity here because it is not widely supported by terminals. 996 | 997 | 998 | ----------------------------------------------------------- 999 | -- Italicization 1000 | ----------------------------------------------------------- 1001 | 1002 | {- 1003 | 1004 | I'm in two minds about providing these functions, since italicization is so rarely implemented. 1005 | It is especially bad because "italicization" may cause the meaning of colors to flip, which will 1006 | look a bit weird, to say the least... 1007 | 1008 | 1009 | -- | Displays a document in italics. This is not widely supported, and it's use is not recommended 1010 | italicize :: Doc -> Doc 1011 | italicize = Italicize True 1012 | 1013 | -- | Displays a document with no italics 1014 | deitalicize :: Doc -> Doc 1015 | deitalicize = Italicize False 1016 | 1017 | -} 1018 | 1019 | ----------------------------------------------------------- 1020 | -- Underlining 1021 | ----------------------------------------------------------- 1022 | 1023 | -- | Displays a document with underlining 1024 | underline :: Doc -> Doc 1025 | underline = Underline SingleUnderline 1026 | 1027 | -- | Displays a document with no underlining 1028 | deunderline :: Doc -> Doc 1029 | deunderline = Underline NoUnderline 1030 | 1031 | -- NB: I don't support DoubleUnderline here because it is not widely supported by terminals. 1032 | 1033 | ----------------------------------------------------------- 1034 | -- Removing formatting 1035 | ----------------------------------------------------------- 1036 | 1037 | -- | Removes all colorisation, emboldening and underlining from a document 1038 | plain :: Doc -> Doc 1039 | plain Fail = Fail 1040 | plain e@Empty = e 1041 | plain c@(Char _) = c 1042 | plain t@(Text _ _) = t 1043 | plain l@Line = l 1044 | plain (FlatAlt x y) = FlatAlt (plain x) (plain y) 1045 | plain (Cat x y) = Cat (plain x) (plain y) 1046 | plain (Nest i x) = Nest i (plain x) 1047 | plain (Union x y) = Union (plain x) (plain y) 1048 | plain (Column f) = Column (plain . f) 1049 | plain (Columns f) = Columns (plain . f) 1050 | plain (Nesting f) = Nesting (plain . f) 1051 | plain (Color _ _ _ x) = plain x 1052 | plain (Intensify _ x) = plain x 1053 | plain (Italicize _ x) = plain x 1054 | plain (Underline _ x) = plain x 1055 | plain (RestoreFormat _ _ _ _ _) = Empty 1056 | 1057 | ----------------------------------------------------------- 1058 | -- Renderers 1059 | ----------------------------------------------------------- 1060 | 1061 | ----------------------------------------------------------- 1062 | -- renderPretty: the default pretty printing algorithm 1063 | ----------------------------------------------------------- 1064 | 1065 | -- list of indentation/document pairs; saves an indirection over [(Int,Doc)] 1066 | data Docs = Nil 1067 | | Cons !Int Doc Docs 1068 | 1069 | 1070 | -- | This is the default pretty printer which is used by 'show', 1071 | -- 'putDoc' and 'hPutDoc'. @(renderPretty ribbonfrac width x)@ renders 1072 | -- document @x@ with a page width of @width@ and a ribbon width of 1073 | -- @(ribbonfrac * width)@ characters. The ribbon width is the maximal 1074 | -- amount of non-indentation characters on a line. The parameter 1075 | -- @ribbonfrac@ should be between @0.0@ and @1.0@. If it is lower or 1076 | -- higher, the ribbon width will be 0 or @width@ respectively. 1077 | renderPretty :: Float -> Int -> Doc -> SimpleDoc 1078 | renderPretty = renderFits fits1 1079 | 1080 | -- | A slightly smarter rendering algorithm with more lookahead. It provides 1081 | -- provide earlier breaking on deeply nested structures 1082 | -- For example, consider this python-ish pseudocode: 1083 | -- @fun(fun(fun(fun(fun([abcdefg, abcdefg])))))@ 1084 | -- If we put a softbreak (+ nesting 2) after each open parenthesis, and align 1085 | -- the elements of the list to match the opening brackets, this will render with 1086 | -- @renderPretty@ and a page width of 20 as: 1087 | -- @ 1088 | -- fun(fun(fun(fun(fun([ 1089 | -- | abcdef, 1090 | -- | abcdef, 1091 | -- ] 1092 | -- ))))) | 1093 | -- @ 1094 | -- Where the 20c. boundary has been marked with |. 1095 | -- Because @renderPretty@ only uses one-line lookahead, it sees that the first 1096 | -- line fits, and is stuck putting the second and third lines after the 20-c 1097 | -- mark. In contrast, @renderSmart@ will continue to check that the potential 1098 | -- document up to the end of the indentation level. Thus, it will format the 1099 | -- document as: 1100 | -- 1101 | -- @ 1102 | -- fun( | 1103 | -- fun( | 1104 | -- fun( | 1105 | -- fun( | 1106 | -- fun([ | 1107 | -- abcdef, 1108 | -- abcdef, 1109 | -- ] | 1110 | -- ))))) | 1111 | -- @ 1112 | -- Which fits within the 20c. boundary. 1113 | renderSmart :: Float -> Int -> Doc -> SimpleDoc 1114 | renderSmart = renderFits fitsR 1115 | 1116 | renderFits :: (Int -> Int -> Int -> SimpleDoc -> Bool) 1117 | -> Float -> Int -> Doc -> SimpleDoc 1118 | renderFits fits rfrac w x 1119 | -- I used to do a @SSGR [Reset]@ here, but if you do that it will result 1120 | -- in any rendered @Doc@ containing at least some ANSI control codes. This 1121 | -- may be undesirable if you want to render to non-ANSI devices by simply 1122 | -- not making use of the ANSI color combinators I provide. 1123 | -- 1124 | -- What I "really" want to do here is do an initial Reset iff there is some 1125 | -- ANSI color within the Doc, but that's a bit fiddly. I'll fix it if someone 1126 | -- complains! 1127 | = best 0 0 Nothing Nothing Nothing Nothing Nothing (Cons 0 x Nil) 1128 | where 1129 | -- r :: the ribbon width in characters 1130 | r = max 0 (min w (round (fromIntegral w * rfrac))) 1131 | 1132 | -- best :: n = indentation of current line 1133 | -- k = current column 1134 | -- (ie. (k >= n) && (k - n == count of inserted characters) 1135 | best n k mb_fc mb_bc mb_in mb_it mb_un Nil = SEmpty 1136 | best n k mb_fc mb_bc mb_in mb_it mb_un (Cons i d ds) 1137 | = case d of 1138 | Fail -> SFail 1139 | Empty -> best_typical n k ds 1140 | Char c -> let k' = k+1 in seq k' (SChar c (best_typical n k' ds)) 1141 | Text l s -> let k' = k+l in seq k' (SText l s (best_typical n k' ds)) 1142 | Line -> SLine i (best_typical i i ds) 1143 | FlatAlt x _ -> best_typical n k (Cons i x ds) 1144 | Cat x y -> best_typical n k (Cons i x (Cons i y ds)) 1145 | Nest j x -> let i' = i+j in seq i' (best_typical n k (Cons i' x ds)) 1146 | Union x y -> nicest n k (best_typical n k (Cons i x ds)) 1147 | (best_typical n k (Cons i y ds)) 1148 | Column f -> best_typical n k (Cons i (f k) ds) 1149 | Columns f -> best_typical n k (Cons i (f (Just w)) ds) 1150 | Nesting f -> best_typical n k (Cons i (f i) ds) 1151 | 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)) 1152 | where 1153 | mb_fc' = case l of { Background -> mb_fc; Foreground -> Just (t, c) } 1154 | mb_bc' = case l of { Background -> Just (t, c); Foreground -> mb_bc } 1155 | Intensify t x -> SSGR [SetConsoleIntensity t] (best n k mb_fc mb_bc (Just t) mb_it mb_un (Cons i x ds_restore)) 1156 | Italicize t x -> SSGR [SetItalicized t] (best n k mb_fc mb_bc mb_in (Just t) mb_un (Cons i x ds_restore)) 1157 | Underline u x -> SSGR [SetUnderlining u] (best n k mb_fc mb_bc mb_in mb_it (Just u) (Cons i x ds_restore)) 1158 | 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) 1159 | where 1160 | -- We need to be able to restore the entire SGR state, hence we carry around what we believe 1161 | -- that state should be in all the arguments to this function. Note that in some cases we could 1162 | -- avoid the Reset of the entire state, but not in general. 1163 | sgrs = Reset : catMaybes [ 1164 | fmap (uncurry (SetColor Foreground)) mb_fc', 1165 | fmap (uncurry (SetColor Background)) mb_bc', 1166 | fmap SetConsoleIntensity mb_in', 1167 | fmap SetItalicized mb_it', 1168 | fmap SetUnderlining mb_un' 1169 | ] 1170 | where 1171 | best_typical n' k' ds' = best n' k' mb_fc mb_bc mb_in mb_it mb_un ds' 1172 | ds_restore = Cons i (RestoreFormat mb_fc mb_bc mb_in mb_it mb_un) ds 1173 | 1174 | --nicest :: r = ribbon width, w = page width, 1175 | -- n = indentation of current line, k = current column 1176 | -- x and y, the (simple) documents to chose from. 1177 | -- precondition: first lines of x are longer than the first lines of y. 1178 | nicest n k x y | fits w (min n k) width x = x 1179 | | otherwise = y 1180 | where 1181 | width = min (w - k) (r - k + n) 1182 | 1183 | -- @fits1@ does 1 line lookahead. 1184 | fits1 :: Int -> Int -> Int -> SimpleDoc -> Bool 1185 | fits1 _ _ w x | w < 0 = False 1186 | fits1 _ _ w SFail = False 1187 | fits1 _ _ w SEmpty = True 1188 | fits1 p m w (SChar c x) = fits1 p m (w - 1) x 1189 | fits1 p m w (SText l s x) = fits1 p m (w - l) x 1190 | fits1 _ _ w (SLine i x) = True 1191 | fits1 p m w (SSGR _ x) = fits1 p m w x 1192 | 1193 | -- @fitsR@ has a little more lookahead: assuming that nesting roughly 1194 | -- corresponds to syntactic depth, @fitsR@ checks that not only the current line 1195 | -- fits, but the entire syntactic structure being formatted at this level of 1196 | -- indentation fits. If we were to remove the second case for @SLine@, we would 1197 | -- check that not only the current structure fits, but also the rest of the 1198 | -- document, which would be slightly more intelligent but would have exponential 1199 | -- runtime (and is prohibitively expensive in practice). 1200 | -- p = pagewidth 1201 | -- m = minimum nesting level to fit in 1202 | -- w = the width in which to fit the first line 1203 | fitsR :: Int -> Int -> Int -> SimpleDoc -> Bool 1204 | fitsR p m w x | w < 0 = False 1205 | fitsR p m w SFail = False 1206 | fitsR p m w SEmpty = True 1207 | fitsR p m w (SChar c x) = fitsR p m (w - 1) x 1208 | fitsR p m w (SText l s x) = fitsR p m (w - l) x 1209 | fitsR p m w (SLine i x) | m < i = fitsR p m (p - i) x 1210 | | otherwise = True 1211 | fitsR p m w (SSGR _ x) = fitsR p m w x 1212 | 1213 | ----------------------------------------------------------- 1214 | -- renderCompact: renders documents without indentation 1215 | -- fast and fewer characters output, good for machines 1216 | ----------------------------------------------------------- 1217 | 1218 | 1219 | -- | @(renderCompact x)@ renders document @x@ without adding any 1220 | -- indentation. Since no \'pretty\' printing is involved, this 1221 | -- renderer is very fast. The resulting output contains fewer 1222 | -- characters than a pretty printed version and can be used for output 1223 | -- that is read by other programs. 1224 | -- 1225 | -- This rendering function does not add any colorisation information. 1226 | renderCompact :: Doc -> SimpleDoc 1227 | renderCompact x 1228 | = scan 0 [x] 1229 | where 1230 | scan k [] = SEmpty 1231 | scan k (d:ds) = case d of 1232 | Fail -> SFail 1233 | Empty -> scan k ds 1234 | Char c -> let k' = k+1 in seq k' (SChar c (scan k' ds)) 1235 | Text l s -> let k' = k+l in seq k' (SText l s (scan k' ds)) 1236 | FlatAlt x _ -> scan k (x:ds) 1237 | Line -> SLine 0 (scan 0 ds) 1238 | Cat x y -> scan k (x:y:ds) 1239 | Nest j x -> scan k (x:ds) 1240 | Union x y -> scan k (y:ds) 1241 | Column f -> scan k (f k:ds) 1242 | Columns f -> scan k (f Nothing:ds) 1243 | Nesting f -> scan k (f 0:ds) 1244 | Color _ _ _ x -> scan k (x:ds) 1245 | Intensify _ x -> scan k (x:ds) 1246 | Italicize _ x -> scan k (x:ds) 1247 | Underline _ x -> scan k (x:ds) 1248 | RestoreFormat _ _ _ _ _ -> scan k ds 1249 | 1250 | 1251 | 1252 | ----------------------------------------------------------- 1253 | -- Displayers: displayS and displayIO 1254 | ----------------------------------------------------------- 1255 | 1256 | 1257 | -- | @(displayS simpleDoc)@ takes the output @simpleDoc@ from a 1258 | -- rendering function and transforms it to a 'ShowS' type (for use in 1259 | -- the 'Show' class). 1260 | -- 1261 | -- > showWidth :: Int -> Doc -> String 1262 | -- > showWidth w x = displayS (renderPretty 0.4 w x) "" 1263 | -- 1264 | -- ANSI color information will be discarded by this function unless 1265 | -- you are running on a Unix-like operating system. This is due to 1266 | -- a technical limitation in Windows ANSI support. 1267 | displayS :: SimpleDoc -> ShowS 1268 | displayS SFail = error $ "@SFail@ can not appear uncaught in a " ++ 1269 | "rendered @SimpleDoc@" 1270 | displayS SEmpty = id 1271 | displayS (SChar c x) = showChar c . displayS x 1272 | displayS (SText l s x) = showString s . displayS x 1273 | displayS (SLine i x) = showString ('\n':indentation i) . displayS x 1274 | displayS (SSGR s x) = showString (setSGRCode s) . displayS x 1275 | 1276 | 1277 | -- | @(displayIO handle simpleDoc)@ writes @simpleDoc@ to the file 1278 | -- handle @handle@. This function is used for example by 'hPutDoc': 1279 | -- 1280 | -- > hPutDoc handle doc = displayIO handle (renderPretty 0.4 100 doc) 1281 | -- 1282 | -- Any ANSI colorisation in @simpleDoc@ will be output. 1283 | displayIO :: Handle -> SimpleDoc -> IO () 1284 | displayIO handle simpleDoc 1285 | = display simpleDoc 1286 | where 1287 | display SFail = error $ "@SFail@ can not appear uncaught in a " ++ 1288 | "rendered @SimpleDoc@" 1289 | display SEmpty = return () 1290 | display (SChar c x) = do{ hPutChar handle c; display x} 1291 | display (SText l s x) = do{ hPutStr handle s; display x} 1292 | display (SLine i x) = do{ hPutStr handle ('\n':indentation i); display x} 1293 | display (SSGR s x) = do{ hSetSGR handle s; display x} 1294 | 1295 | ----------------------------------------------------------- 1296 | -- default pretty printers: show, putDoc and hPutDoc 1297 | ----------------------------------------------------------- 1298 | instance Show Doc where 1299 | showsPrec d doc = displayS (renderPretty 0.4 80 doc) 1300 | 1301 | -- | The action @(putDoc doc)@ pretty prints document @doc@ to the 1302 | -- standard output, with a page width of 100 characters and a ribbon 1303 | -- width of 40 characters. 1304 | -- 1305 | -- > main :: IO () 1306 | -- > main = do{ putDoc (text "hello" <+> text "world") } 1307 | -- 1308 | -- Which would output 1309 | -- 1310 | -- @ 1311 | -- hello world 1312 | -- @ 1313 | -- 1314 | -- Any ANSI colorisation in @doc@ will be output. 1315 | putDoc :: Doc -> IO () 1316 | putDoc doc = hPutDoc stdout doc 1317 | 1318 | -- | @(hPutDoc handle doc)@ pretty prints document @doc@ to the file 1319 | -- handle @handle@ with a page width of 100 characters and a ribbon 1320 | -- width of 40 characters. 1321 | -- 1322 | -- > main = do{ handle <- openFile "MyFile" WriteMode 1323 | -- > ; hPutDoc handle (vcat (map text 1324 | -- > ["vertical","text"])) 1325 | -- > ; hClose handle 1326 | -- > } 1327 | -- 1328 | -- Any ANSI colorisation in @doc@ will be output. 1329 | hPutDoc :: Handle -> Doc -> IO () 1330 | hPutDoc handle doc = displayIO handle (renderPretty 0.4 80 doc) 1331 | 1332 | 1333 | 1334 | ----------------------------------------------------------- 1335 | -- insert spaces 1336 | -- "indentation" used to insert tabs but tabs seem to cause 1337 | -- more trouble than they solve :-) 1338 | ----------------------------------------------------------- 1339 | spaces :: Int -> String 1340 | spaces n | n <= 0 = "" 1341 | | otherwise = replicate n ' ' 1342 | 1343 | indentation :: Int -> String 1344 | indentation n = spaces n 1345 | 1346 | --indentation n | n >= 8 = '\t' : indentation (n-8) 1347 | -- | otherwise = spaces n 1348 | 1349 | -- LocalWords: PPrint combinators Wadler Wadler's encloseSep 1350 | --------------------------------------------------------------------------------