1 2 A Document is at heart ShowS from the prelude 3 \htmladdnormallink{http://www.haskell.org/onlinereport/standard-prelude.html#\$tShowS} 4 5 Essentially, if you give a Doc a string it'll print out whatever it 6 wants followed by that string. So \verb!(text "foo")! makes the Doc that 7 prints \verb!"foo"! followed by its argument. The combinator names are taken 8 from Text.PrettyPrint.HughesPJ, although the behaviour of the two libraries is 9 slightly different. 10 11 The advantage of Printer over simple string appending/concatenating is 12 that the appends end up associating to the right, e.g.: 13 14 \begin{verbatim} 15 (text "foo" <> text "bar") <> (text "baz" <> text "quux") "" 16 = \s -> (text "foo" <> text "bar") ((text "baz" <> text "quux") s) "" 17 = (text "foo" <> text "bar") ((text "baz" <> text "quux") "") 18 = (\s -> (text "foo") (text "bar" s)) ((text "baz" <> text "quux") "") 19 = text "foo" (text "bar" ((text "baz" <> text "quux") "")) 20 = (\s -> "foo" ++ s) (text "bar" ((text "baz" <> text "quux") "")) 21 = "foo" ++ (text "bar" ((text "baz" <> text "quux") "")) 22 = "foo" ++ ("bar" ++ ((text "baz" <> text "quux") "")) 23 = "foo" ++ ("bar" ++ ((\s -> text "baz" (text "quux" s)) "")) 24 = "foo" ++ ("bar" ++ (text "baz" (text "quux" ""))) 25 = "foo" ++ ("bar" ++ ("baz" ++ (text "quux" ""))) 26 = "foo" ++ ("bar" ++ ("baz" ++ ("quux" ++ ""))) 27 \end{verbatim} 28 29 The Empty alternative comes in because you want 30 \begin{verbatim} 31 text "a" $$ vcat xs $$ text "b" 32 \end{verbatim} 33 (\verb!$$! means ``above'', vcat is the list version of \verb!$$!) to be 34 \verb!"a\nb"! when \verb!xs! is \verb![]!, but without the concept of an 35 Empty Document each \verb!$$! would add a \verb!'\n'! and you'd end up with 36 \verb!"a\n\nb"!. Note that \verb!Empty /= text ""! (the latter would cause two 37 \verb!'\n'!s). 38 39 This code was made generic in the element type by Juliusz Chroboczek. 40 \begin{code} 41 module Printer (Printable(..), Doc(Doc,unDoc), Printers, Printers'(..), Printer, Color(..), 42 hPutDoc, hPutDocLn, putDoc, putDocLn, 43 hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith, 44 renderString, renderStringWith, renderPS, renderPSWith, 45 renderPSs, renderPSsWith, lineColor, 46 prefix, insert_before_lastline, colorText, invisibleText, 47 hiddenText, hiddenPrefix, userchunk, text, 48 printable, wrap_text, 49 blueText, redText, greenText, magentaText, cyanText, 50 unsafeText, unsafeBoth, unsafeBothText, unsafeChar, 51 invisiblePS, packedString, unsafePackedString, userchunkPS, 52 simplePrinters, invisiblePrinter, simplePrinter, 53 doc, empty, (<>), (<?>), (<+>), ($$), vcat, vsep, hcat, 54 minus, newline, plus, space, backslash, lparen, rparen, 55 parens, 56 errorDoc, 57 ) where 58 59 import Data.List (intersperse) 60 import System.IO (Handle, stdout, hPutStr) 61 import ByteStringUtils ( linesPS ) 62 import qualified Data.ByteString as B (ByteString, hPut, concat) 63 import qualified Data.ByteString.Char8 as BC (unpack, pack, singleton) 64 65 -- | A 'Printable' is either a String, a packed string, or a chunk of 66 -- text with both representations. 67 data Printable = S !String 68 | PS !B.ByteString 69 | Both !String !B.ByteString 70 71 -- | 'space_p' is the 'Printable' representation of a space. 72 space_p :: Printable 73 space_p = Both " " (BC.singleton ' ') 74 75 -- | 'newline_p' is the 'Printable' representation of a newline. 76 newline_p :: Printable 77 newline_p = S "\n" 78 79 -- | Minimal 'Doc's representing the common characters 'space', 'newline' 80 -- 'minus', 'plus', and 'backslash'. 81 space, newline, plus, minus, backslash :: Doc 82 space = unsafeBoth " " (BC.singleton ' ') 83 newline = unsafeChar '\n' 84 minus = unsafeBoth "-" (BC.singleton '-') 85 plus = unsafeBoth "+" (BC.singleton '+') 86 backslash = unsafeBoth "\\" (BC.singleton '\\') 87 88 -- | 'lparen' is the 'Doc' that represents @\"(\"@ 89 lparen :: Doc 90 lparen = unsafeBoth "(" (BC.singleton '(') 91 92 -- | 'rparen' is the 'Doc' that represents @\")\"@ 93 rparen :: Doc 94 rparen = unsafeBoth ")" (BC.singleton ')') 95 96 -- | @'parens' doc@ returns a 'Doc' with the content of @doc@ put within 97 -- a pair of parenthesis. 98 parens :: Doc -> Doc 99 parens d = lparen <> d <> rparen 100 101 errorDoc :: Doc -> a 102 errorDoc = error . renderStringWith simplePrinters' 103 104 105 -- | 'putDocWith' puts a doc on stdout using the given printer. 106 putDocWith :: Printers -> Doc -> IO () 107 putDocWith prs = hPutDocWith prs stdout 108 109 -- | 'putDocLnWith' puts a doc, followed by a newline on stdout using 110 -- the given printer. 111 putDocLnWith :: Printers -> Doc -> IO () 112 putDocLnWith prs = hPutDocLnWith prs stdout 113 114 115 -- | 'putDoc' puts a doc on stdout using the simple printer 'simplePrinters'. 116 putDoc :: Doc -> IO () 117 -- | 'putDocLn' puts a doc, followed by a newline on stdout using 118 -- 'simplePrinters' 119 putDocLn :: Doc -> IO () 120 putDoc = hPutDoc stdout 121 putDocLn = hPutDocLn stdout 122 123 -- | 'hputDocWith' puts a doc on the given handle using the given printer. 124 hPutDocWith :: Printers -> Handle -> Doc -> IO () 125 -- | 'hputDocLnWith' puts a doc, followed by a newline on the given 126 -- handle using the given printer. 127 hPutDocLnWith :: Printers -> Handle -> Doc -> IO () 128 129 hPutDocWith prs h d = hPrintPrintables h (renderWith (prs h) d) 130 hPutDocLnWith prs h d = hPutDocWith prs h (d <?> newline) 131 132 -- |'hputDoc' puts a doc on the given handle using 'simplePrinters' 133 hPutDoc :: Handle -> Doc -> IO () 134 -- 'hputDocLn' puts a doc, followed by a newline on the given handle using 135 -- 'simplePrinters'. 136 hPutDocLn :: Handle -> Doc -> IO () 137 hPutDoc = hPutDocWith simplePrinters 138 hPutDocLn = hPutDocLnWith simplePrinters 139 140 -- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle h 141 hPrintPrintables :: Handle -> [Printable] -> IO () 142 hPrintPrintables h = mapM_ (hPrintPrintable h) 143 144 -- | @hPrintPrintable h@ prints a 'Printable' to the handle h. 145 hPrintPrintable :: Handle -> Printable -> IO () 146 hPrintPrintable h (S ps) = hPutStr h ps 147 hPrintPrintable h (PS ps) = B.hPut h ps 148 hPrintPrintable h (Both _ ps) = B.hPut h ps 149 150 -- | a 'Doc' is a bit of enriched text. 'Doc's get concatanated using 151 -- '<>', which is right-associative. 152 newtype Doc = Doc { unDoc :: St -> Document } 153 154 -- | The State associated with a doc. Contains a set of printers for each 155 -- hanlde, and the current prefix of the document. 156 data St = St { printers :: !Printers', 157 current_prefix :: !([Printable] -> [Printable]) } 158 type Printers = Handle -> Printers' 159 160 -- | A set of printers to print different types of text to a handle. 161 data Printers' = Printers {colorP :: !(Color -> Printer), 162 invisibleP :: !Printer, 163 hiddenP :: !Printer, 164 userchunkP :: !Printer, 165 defP :: !Printer, 166 lineColorT :: !(Color -> Doc -> Doc), 167 lineColorS :: !([Printable] -> [Printable]) 168 } 169 type Printer = Printable -> St -> Document 170 171 data Color = Blue | Red | Green | Cyan | Magenta 172 173 -- | 'Document' is a wrapper around '[Printable] -> [Printable]' which allows 174 -- for empty Documents. The simplest 'Documents' are built from 'String's 175 -- using 'text'. 176 data Document = Document ([Printable] -> [Printable]) 177 | Empty 178 179 -- | renders a 'Doc' into a 'String' with control codes for the 180 -- special features of the doc. 181 renderString :: Doc -> String 182 renderString = renderStringWith simplePrinters' 183 184 -- | renders a 'Doc' into a 'String' using a given set of printers. 185 renderStringWith :: Printers' -> Doc -> String 186 renderStringWith prs d = concatMap toString $ renderWith prs d 187 where toString (S s) = s 188 toString (PS ps) = BC.unpack ps 189 toString (Both s _) = s 190 191 -- | renders a 'Doc' into 'B.ByteString' with control codes for the 192 -- special features of the Doc. See also 'readerString'. 193 renderPS :: Doc -> B.ByteString 194 renderPS = renderPSWith simplePrinters' 195 196 -- | renders a 'Doc' into a list of 'PackedStrings', one for each line. 197 renderPSs :: Doc -> [B.ByteString] 198 renderPSs = renderPSsWith simplePrinters' 199 200 -- | renders a doc into a 'B.ByteString' using a given set of printers. 201 renderPSWith :: Printers' -> Doc -> B.ByteString 202 renderPSWith prs d = B.concat $ renderPSsWith prs d 203 204 -- | renders a 'Doc' into a list of 'PackedStrings', one for each 205 -- chunk of text that was added to the doc, using the given set of 206 -- printers. 207 renderPSsWith :: Printers' -> Doc -> [B.ByteString] 208 renderPSsWith prs d = map toPS $ renderWith prs d 209 where toPS (S s) = BC.pack s 210 toPS (PS ps) = ps 211 toPS (Both _ ps) = ps 212 213 -- | renders a 'Doc' into a list of 'Printables' using a set of 214 -- printers. Each item of the list corresponds to a string that was 215 -- added to the doc. 216 renderWith :: Printers' -> Doc -> [Printable] 217 renderWith ps (Doc d) = case d (init_state ps) of 218 Empty -> [] 219 Document f -> f [] 220 221 init_state :: Printers' -> St 222 init_state prs = St { printers = prs, current_prefix = id } 223 224 prefix :: String -> Doc -> Doc 225 prefix s (Doc d) = Doc $ \st -> 226 let p = S s 227 st' = st { current_prefix = current_prefix st . (p:) } in 228 case d st' of 229 Document d'' -> Document $ (p:) . d'' 230 Empty -> Empty 231 232 233 insert_before_lastline :: Doc -> Doc -> Doc 234 insert_before_lastline a b = 235 case reverse $ map packedString $ linesPS $ renderPS a of 236 (ll:ls) -> vcat (reverse ls) $$ b $$ ll 237 [] -> error "empty Doc given as first argument of Printer.insert_before_last_line" 238 239 240 lineColor :: Color -> Doc -> Doc 241 lineColor c d = Doc $ \st -> case lineColorT (printers st) c d of 242 Doc d' -> d' st 243 244 hiddenPrefix :: String -> Doc -> Doc 245 hiddenPrefix s (Doc d) = 246 Doc $ \st -> let pr = printers st 247 p = S (renderStringWith pr $ hiddenText s) 248 st' = st { current_prefix = current_prefix st . (p:) } 249 in case d st' of 250 Document d'' -> Document $ (p:) . d'' 251 Empty -> Empty 252 253 -- | 'unsafeBoth' builds a Doc from a 'String' and a 'B.ByteString' representing 254 -- the same text, but does not check that they do. 255 unsafeBoth :: String -> B.ByteString -> Doc 256 unsafeBoth s ps = Doc $ simplePrinter (Both s ps) 257 258 -- | 'unsafeBothText' builds a 'Doc' from a 'String'. The string is stored in the 259 -- Doc as both a String and a 'B.ByteString'. 260 unsafeBothText :: String -> Doc 261 unsafeBothText s = Doc $ simplePrinter (Both s (BC.pack s)) 262 263 -- | 'packedString' builds a 'Doc' from a 'B.ByteString' using 'printable' 264 packedString :: B.ByteString -> Doc 265 -- | 'unsafePackedString' builds a 'Doc' from a 'B.ByteString' using 'simplePrinter' 266 unsafePackedString :: B.ByteString -> Doc 267 -- | 'invisiblePS' creates a 'Doc' with invisible text from a 'B.ByteString' 268 invisiblePS :: B.ByteString -> Doc 269 -- | 'userchunkPS' creates a 'Doc' representing a user chunk from a 'B.ByteString'. 270 userchunkPS :: B.ByteString -> Doc 271 packedString = printable . PS 272 unsafePackedString = Doc . simplePrinter . PS 273 invisiblePS = invisiblePrintable . PS 274 userchunkPS = userchunkPrintable . PS 275 276 -- | 'unsafeChar' creates a Doc containing just one character. 277 unsafeChar :: Char -> Doc 278 unsafeChar = unsafeText . (:"") 279 280 -- | 'text' creates a 'Doc' from a @String@, using 'printable'. 281 text :: String -> Doc 282 -- | 'unsafeText' creates a 'Doc' from a 'String', using 'simplePrinter' directly 283 unsafeText :: String -> Doc 284 -- | 'invisibleText' creates a 'Doc' containing invisible text from a @String@ 285 invisibleText :: String -> Doc 286 -- | 'hiddenText' creates a 'Doc' containing hidden text from a @String@ 287 hiddenText :: String -> Doc 288 -- | 'userchunk' creates a 'Doc' containing a user chunk from a @String@ 289 userchunk :: String -> Doc 290 -- | 'blueText' creates a 'Doc' containing blue text from a @String@ 291 blueText, redText, greenText, magentaText, cyanText :: String -> Doc 292 text = printable . S 293 unsafeText = Doc . simplePrinter . S 294 invisibleText = invisiblePrintable . S 295 hiddenText = hiddenPrintable . S 296 userchunk = userchunkPrintable . S 297 blueText = colorText Blue 298 redText = colorText Red 299 greenText = colorText Green 300 magentaText = colorText Magenta 301 cyanText = colorText Cyan 302 303 -- | 'colorText' creates a 'Doc' containing colored text from a @String@ 304 colorText :: Color -> String -> Doc 305 colorText c = mkColorPrintable c . S 306 307 -- | @'wrap_text' n s@ is a 'Doc' representing @s@ line-wrapped at 'n' characters 308 wrap_text :: Int -> String -> Doc 309 wrap_text n s = 310 vcat $ map text $ reverse $ "": (foldl add_to_line [] $ words s) 311 where add_to_line [] a = [a] 312 add_to_line ("":d) a = (a:d) 313 add_to_line (l:ls) new | length l + length new > n = new:l:ls 314 add_to_line (l:ls) new = (l ++ " " ++ new):ls 315 316 -- | 'printable x' creates a 'Doc' from any 'Printable'. 317 printable, invisiblePrintable, hiddenPrintable, userchunkPrintable :: Printable -> Doc 318 printable x = Doc $ \st -> defP (printers st) x st 319 320 mkColorPrintable :: Color -> Printable -> Doc 321 mkColorPrintable c x = Doc $ \st -> colorP (printers st) c x st 322 invisiblePrintable x = Doc $ \st -> invisibleP (printers st) x st 323 hiddenPrintable x = Doc $ \st -> hiddenP (printers st) x st 324 userchunkPrintable x = Doc $ \st -> userchunkP (printers st) x st 325 326 -- | 'simplePrinters' is a 'Printers' which uses the set 'simplePriners\'' on any 327 -- handle. 328 simplePrinters :: Printers 329 simplePrinters _ = simplePrinters' 330 331 -- | A set of default printers suitable for any handle. Does not use color. 332 simplePrinters' :: Printers' 333 simplePrinters' = Printers { colorP = const simplePrinter, 334 invisibleP = simplePrinter, 335 hiddenP = invisiblePrinter, 336 userchunkP = simplePrinter, 337 defP = simplePrinter, 338 lineColorT = const id, 339 lineColorS = id 340 } 341 342 -- | 'simplePrinter' is the simplest 'Printer': it just concatenates together 343 -- the pieces of the 'Doc' 344 simplePrinter :: Printer 345 -- | 'invisiblePrinter' is the 'Printer' for hidden text. It just replaces 346 -- the document with 'empty'. It's useful to have a printer that doesn't 347 -- actually do anything because this allows you to have tunable policies, 348 -- for example, only printing some text if it's to the terminal, but not 349 -- if it's to a file or vice-versa. 350 invisiblePrinter :: Printer 351 simplePrinter x = unDoc $ doc (\s -> x:s) 352 invisiblePrinter _ = unDoc empty 353 354 infixr 6 <> 355 infixr 6 <+> 356 infixr 5 $$ 357 358 -- | The empty 'Doc'. 359 empty :: Doc 360 empty = Doc $ const Empty 361 doc :: ([Printable] -> [Printable]) -> Doc 362 doc f = Doc $ const $ Document f 363 364 -- | '(<>)' is the concatenation operator for 'Doc's 365 (<>) :: Doc -> Doc -> Doc 366 -- | @a '<?>' b@ is @a@ if it is not empty, else @b@. 367 (<?>) :: Doc -> Doc -> Doc 368 -- | @a '<+>' b@ is @a@ followed by a space, then @b@. 369 (<+>) :: Doc -> Doc -> Doc 370 -- | @a '$$' b@ is @a@ above @b@. 371 ($$) :: Doc -> Doc -> Doc 372 -- a then b 373 Doc a <> Doc b = 374 Doc $ \st -> case a st of 375 Empty -> b st 376 Document af -> 377 Document (\s -> af $ case b st of 378 Empty -> s 379 Document bf -> bf s) 380 381 -- empty if a empty, else a then b 382 Doc a <?> Doc b = 383 Doc $ \st -> case a st of 384 Empty -> Empty 385 Document af -> Document (\s -> af $ case b st of 386 Empty -> s 387 Document bf -> bf s) 388 389 -- a then space then b 390 Doc a <+> Doc b = 391 Doc $ \st -> case a st of 392 Empty -> b st 393 Document af -> Document (\s -> af $ case b st of 394 Empty -> s 395 Document bf -> 396 space_p:bf s) 397 398 -- a above b 399 Doc a $$ Doc b = 400 Doc $ \st -> case a st of 401 Empty -> b st 402 Document af -> 403 Document (\s -> af $ case b st of 404 Empty -> s 405 Document bf -> sf (newline_p:pf (bf s))) 406 where pf = current_prefix st 407 sf = lineColorS $ printers st 408 409 -- | 'vcat' piles vertically a list of 'Doc's. 410 vcat :: [Doc] -> Doc 411 vcat [] = empty 412 vcat ds = foldr1 ($$) ds 413 414 -- | 'vsep' piles vertically a list of 'Doc's leaving a blank line between each. 415 vsep :: [Doc] -> Doc 416 vsep [] = empty 417 vsep ds = foldr1 ($$) $ intersperse (text "") ds 418 419 -- | 'hcat' concatenates (horizontally) a list of 'Doc's 420 hcat :: [Doc] -> Doc 421 hcat [] = empty 422 hcat ds = foldr1 (<>) ds 423 424 \end{code} 425