src/Printer.lhs

   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, colorText, invisibleText, hiddenText, hiddenPrefix, userchunk, text,
  47                 printable, wrap_text,
  48                 blueText, redText, greenText, magentaText, cyanText,
  49                 unsafeText, unsafeBoth, unsafeBothText, unsafeChar,
  50                 invisiblePS, packedString, unsafePackedString, userchunkPS,
  51                 simplePrinters, invisiblePrinter, simplePrinter,
  52                 doc, empty, (<>), (<?>), (<+>), ($$), vcat, vsep, hcat,
  53                 minus, newline, plus, space, backslash, lparen, rparen,
  54                 parens,
  55                 errorDoc,
  56                ) where
  57
  58 import Control.Monad.Reader (Reader, runReader, ask, asks, local)
  59 import Data.List (intersperse)
  60 import System.IO (Handle, stdout, hPutStr)
  61 import qualified Data.ByteString as B (ByteString, hPut, concat)
  62 import qualified Data.ByteString.Char8 as BC (unpack, pack, singleton)
  63
  64 -- | A 'Printable' is either a String, a packed string, or a chunk of
  65 -- text with both representations.
  66 data Printable = S !String
  67                | PS !B.ByteString
  68                | Both !String !B.ByteString
  69
  70 -- | 'space_p' is the 'Printable' representation of a space.
  71 space_p :: Printable
  72 space_p   = Both " "  (BC.singleton ' ')
  73
  74 -- | 'newline_p' is the 'Printable' representation of a newline.
  75 newline_p :: Printable
  76 newline_p = S "\n"
  77
  78 -- | Minimal 'Doc's representing the common characters 'space', 'newline'
  79 -- 'minus', 'plus', and 'backslash'.
  80 space, newline, plus, minus, backslash :: Doc
  81 space     = unsafeBoth " "  (BC.singleton ' ')
  82 newline   = unsafeChar '\n'
  83 minus     = unsafeBoth "-"  (BC.singleton '-')
  84 plus      = unsafeBoth "+"  (BC.singleton '+')
  85 backslash = unsafeBoth "\\" (BC.singleton '\\')
  86
  87 -- | 'lparen' is the 'Doc' that represents @\"(\"@
  88 lparen :: Doc
  89 lparen = unsafeBoth  "(" (BC.singleton '(')
  90
  91 -- | 'rparen' is the 'Doc' that represents @\")\"@
  92 rparen :: Doc
  93 rparen = unsafeBoth ")" (BC.singleton ')')
  94
  95 -- | @'parens' doc@ returns a 'Doc' with the content of @doc@ put within
  96 -- a pair of parenthesis.
  97 parens :: Doc -> Doc
  98 parens d = lparen <> d <> rparen
  99
 100 errorDoc :: Doc -> a
 101 errorDoc = error . renderStringWith simplePrinters'
 102
 103
 104 -- | 'putDocWith' puts a doc on stdout using the given printer.
 105 putDocWith :: Printers -> Doc -> IO ()
 106 putDocWith prs = hPutDocWith prs stdout
 107
 108 -- | 'putDocLnWith' puts a doc, followed by a newline on stdout using
 109 -- the given printer.
 110 putDocLnWith :: Printers -> Doc -> IO ()
 111 putDocLnWith prs = hPutDocLnWith prs stdout
 112
 113
 114 -- | 'putDoc' puts a doc on stdout using the simple printer 'simplePrinters'.
 115 putDoc :: Doc -> IO ()
 116 -- | 'putDocLn' puts a doc, followed by a newline on stdout using
 117 -- 'simplePrinters'
 118 putDocLn :: Doc -> IO ()
 119 putDoc = hPutDoc stdout
 120 putDocLn = hPutDocLn stdout
 121
 122 -- | 'hputDocWith' puts a doc on the given handle using the given printer.
 123 hPutDocWith :: Printers -> Handle -> Doc -> IO ()
 124 -- | 'hputDocLnWith' puts a doc, followed by a newline on the given
 125 -- handle using the given printer.
 126 hPutDocLnWith :: Printers -> Handle -> Doc -> IO ()
 127
 128 hPutDocWith prs h d = hPrintPrintables h (renderWith (prs h) d)
 129 hPutDocLnWith prs h d = hPutDocWith prs h (d <?> newline)
 130
 131 -- |'hputDoc' puts a doc on the given handle using 'simplePrinters'
 132 hPutDoc :: Handle -> Doc -> IO ()
 133 -- 'hputDocLn' puts a doc, followed by a newline on the given handle using
 134 -- 'simplePrinters'.
 135 hPutDocLn :: Handle -> Doc -> IO ()
 136 hPutDoc = hPutDocWith simplePrinters
 137 hPutDocLn = hPutDocLnWith simplePrinters
 138
 139 -- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle h
 140 hPrintPrintables :: Handle -> [Printable] -> IO ()
 141 hPrintPrintables h = mapM_ (hPrintPrintable h)
 142
 143 -- | @hPrintPrintable h@ prints a 'Printable' to the handle h.
 144 hPrintPrintable :: Handle -> Printable -> IO ()
 145 hPrintPrintable h (S ps) = hPutStr h ps
 146 hPrintPrintable h (PS ps) = B.hPut h ps
 147 hPrintPrintable h (Both _ ps) = B.hPut h ps
 148
 149 -- | a 'Doc' is a bit of enriched text. 'Doc's get concatanated using
 150 -- '<>', which is right-associative.
 151 newtype Doc = Doc { unDoc :: Reader St Document }
 152
 153 -- | The State associated with a doc. Contains a set of printers for each
 154 -- hanlde, and the current prefix of the document.
 155 data St = St { printers :: !Printers', current_prefix :: !DocumentInternals }
 156 type Printers = Handle -> Printers'
 157
 158 -- | A set of printers to print different types of text to a handle.
 159 data Printers' = Printers {colorP :: !(Color -> Printer),
 160                            invisibleP :: !Printer,
 161                            hiddenP :: !Printer,
 162                            userchunkP :: !Printer,
 163                            defP :: !Printer,
 164                            lineColorT :: !(Color -> Doc -> Doc),
 165                            lineColorS :: !DocumentInternals
 166                           }
 167 type Printer = Printable -> Reader St Document
 168
 169 data Color = Blue | Red | Green | Cyan | Magenta
 170
 171 -- | 'DocumentInternals' represents a 'Printable' by the function
 172 -- which concatenates another 'Printable' to its right.
 173 type DocumentInternals = [Printable] -> [Printable]
 174
 175 -- | 'Document' is a wrapper around 'DocumentInternals' which allows
 176 -- for empty Documents. The simplest 'Documents' are built from 'String's
 177 -- using 'text'.
 178 data Document = Document DocumentInternals
 179               | Empty
 180
 181 -- | renders a 'Doc' into a 'String' with control codes for the
 182 -- special features of the doc.
 183 renderString :: Doc -> String
 184 renderString = renderStringWith simplePrinters'
 185
 186 -- | renders a 'Doc' into a 'String' using a given set of printers.
 187 renderStringWith :: Printers' -> Doc -> String
 188 renderStringWith prs d = concatMap toString $ renderWith prs d
 189     where toString (S s) = s
 190           toString (PS ps) = BC.unpack ps
 191           toString (Both s _) = s
 192
 193 -- | renders a 'Doc' into 'B.ByteString' with control codes for the
 194 -- special features of the Doc. See also 'readerString'.
 195 renderPS :: Doc -> B.ByteString
 196 renderPS = renderPSWith simplePrinters'
 197
 198 -- | renders a 'Doc' into a list of 'PackedStrings', one for each line.
 199 renderPSs :: Doc -> [B.ByteString]
 200 renderPSs = renderPSsWith simplePrinters'
 201
 202 -- | renders a doc into a 'B.ByteString' using a given set of printers.
 203 renderPSWith :: Printers' -> Doc -> B.ByteString
 204 renderPSWith prs d = B.concat $ renderPSsWith prs d
 205
 206 -- | renders a 'Doc' into a list of 'PackedStrings', one for each
 207 -- chunk of text that was added to the doc, using the given set of
 208 -- printers.
 209 renderPSsWith :: Printers' -> Doc -> [B.ByteString]
 210 renderPSsWith prs d = map toPS $ renderWith prs d
 211     where toPS (S s)        = BC.pack s
 212           toPS (PS ps)      = ps
 213           toPS (Both _ ps)  = ps
 214
 215 -- | renders a 'Doc' into a list of 'Printables' using a set of
 216 -- printers. Each item of the list corresponds to a string that was
 217 -- added to the doc.
 218 renderWith :: Printers' -> Doc -> [Printable]
 219 renderWith ps (Doc d) = case runReader d (init_state ps) of
 220                         Empty -> []
 221                         Document f -> f []
 222
 223 init_state :: Printers' -> St
 224 init_state prs = St { printers = prs, current_prefix = id }
 225
 226 prefix :: String -> Doc -> Doc
 227 prefix s (Doc d) =
 228     Doc $ local (\st -> st { current_prefix = current_prefix st . (p:) })
 229                    (do d' <- d
 230                        case d' of
 231                            Document d'' -> return $ Document $ (p:) . d''
 232                            Empty -> return Empty)
 233     where p = S s
 234
 235 lineColor :: Color -> Doc -> Doc
 236 lineColor c d =
 237     Doc $ do pr <- asks printers
 238              unDoc $ lineColorT pr c d
 239
 240 hiddenPrefix :: String -> Doc -> Doc
 241 hiddenPrefix s (Doc d) =
 242     Doc $ do pr <- asks printers
 243              let p = S (renderStringWith pr $ hiddenText s)
 244              local (\st -> st { current_prefix = current_prefix st . (p:) })
 245                        (do d' <- d
 246                            case d' of
 247                              Document d'' -> return $ Document $ (p:) . d''
 248                              Empty -> return Empty)
 249
 250 -- | 'unsafeBoth' builds a Doc from a 'String' and a 'B.ByteString' representing
 251 -- the same text, but does not check that they do.
 252 unsafeBoth :: String -> B.ByteString -> Doc
 253 unsafeBoth s ps = Doc $ simplePrinter (Both s ps)
 254
 255 -- | 'unsafeBothText' builds a 'Doc' from a 'String'. The string is stored in the
 256 -- Doc as both a String and a 'B.ByteString'.
 257 unsafeBothText :: String -> Doc
 258 unsafeBothText s = Doc $ simplePrinter (Both s (BC.pack s))
 259
 260 -- | 'packedString' builds a 'Doc' from a 'B.ByteString' using 'printable'
 261 packedString :: B.ByteString -> Doc
 262 -- | 'unsafePackedString' builds a 'Doc' from a 'B.ByteString' using 'simplePrinter'
 263 unsafePackedString :: B.ByteString -> Doc
 264 -- | 'invisiblePS' creates a 'Doc' with invisible text from a 'B.ByteString'
 265 invisiblePS :: B.ByteString -> Doc
 266 -- | 'userchunkPS' creates a 'Doc' representing a user chunk from a 'B.ByteString'.
 267 userchunkPS :: B.ByteString -> Doc
 268 packedString = printable . PS
 269 unsafePackedString = Doc . simplePrinter . PS
 270 invisiblePS = invisiblePrintable . PS
 271 userchunkPS = userchunkPrintable . PS
 272
 273 -- | 'unsafeChar' creates a Doc containing just one character.
 274 unsafeChar :: Char -> Doc
 275 unsafeChar = unsafeText . return
 276
 277 -- | 'text' creates a 'Doc' from a @String@, using 'printable'.
 278 text :: String -> Doc
 279 -- | 'unsafeText' creates a 'Doc' from a 'String', using 'simplePrinter' directly
 280 unsafeText :: String -> Doc
 281 -- | 'invisibleText' creates a 'Doc' containing invisible text from a @String@
 282 invisibleText :: String -> Doc
 283 -- | 'hiddenText' creates a 'Doc' containing hidden text from a @String@
 284 hiddenText :: String -> Doc
 285 -- | 'userchunk' creates a 'Doc' containing a user chunk from a @String@
 286 userchunk :: String -> Doc
 287 -- | 'blueText' creates a 'Doc' containing blue text from a @String@
 288 blueText, redText, greenText, magentaText, cyanText :: String -> Doc
 289 text = printable . S
 290 unsafeText = Doc . simplePrinter . S
 291 invisibleText = invisiblePrintable . S
 292 hiddenText = hiddenPrintable . S
 293 userchunk = userchunkPrintable . S
 294 blueText = colorText Blue
 295 redText = colorText Red
 296 greenText = colorText Green
 297 magentaText = colorText Magenta
 298 cyanText = colorText Cyan
 299
 300 -- | 'colorText' creates a 'Doc' containing colored text from a @String@
 301 colorText :: Color -> String -> Doc
 302 colorText c = mkColorPrintable c . S
 303
 304 -- | @'wrap_text' n s@ is a 'Doc' representing @s@ line-wrapped at 'n' characters
 305 wrap_text :: Int -> String -> Doc
 306 wrap_text n s =
 307     vcat $ map text $ reverse $ "": (foldl add_to_line [] $ words s)
 308   where add_to_line [] a = [a]
 309         add_to_line ("":d) a = (a:d)
 310         add_to_line (l:ls) new | length l + length new > n = new:l:ls
 311         add_to_line (l:ls) new = (l ++ " " ++ new):ls
 312
 313 -- | 'printable x' creates a 'Doc' from any 'Printable'.
 314 printable, invisiblePrintable, hiddenPrintable, userchunkPrintable :: Printable -> Doc
 315 printable x = Doc $ do st <- ask
 316                        defP (printers st) x
 317 mkColorPrintable :: Color -> Printable -> Doc
 318 mkColorPrintable c x = Doc $ do st <- ask
 319                                 colorP (printers st) c x
 320 invisiblePrintable x = Doc $ do st <- ask
 321                                 invisibleP (printers st) x
 322 hiddenPrintable x = Doc $ do st <- ask
 323                              hiddenP (printers st) x
 324 userchunkPrintable x = Doc $ do st <- ask
 325                                 userchunkP (printers st) x
 326
 327 -- | 'simplePrinters' is a 'Printers' which uses the set 'simplePriners\'' on any
 328 -- handle.
 329 simplePrinters :: Printers
 330 simplePrinters _ = simplePrinters'
 331
 332 -- | A set of default printers suitable for any handle. Does not use color.
 333 simplePrinters' :: Printers'
 334 simplePrinters'  = Printers { colorP = const simplePrinter,
 335                               invisibleP = simplePrinter,
 336                               hiddenP = invisiblePrinter,
 337                               userchunkP = simplePrinter,
 338                               defP = simplePrinter,
 339                               lineColorT = const id,
 340                               lineColorS = id
 341                             }
 342
 343 -- | 'simplePrinter' is the simplest 'Printer': it just concatenates together
 344 -- the pieces of the 'Doc'
 345 simplePrinter :: Printer
 346 -- | 'invisiblePrinter' is the 'Printer' for hidden text. It seems to
 347 -- just replace the document with 'empty'. I'm confused (Florent).
 348 invisiblePrinter :: Printer
 349 simplePrinter x = unDoc $ doc (\s -> x:s)
 350 invisiblePrinter _ = unDoc empty
 351
 352 infixr 6 <>
 353 infixr 6 <+>
 354 infixr 5 $$
 355
 356 -- | The empty 'Doc'.
 357 empty :: Doc
 358 empty = Doc $ return Empty
 359 doc :: ([Printable] -> [Printable]) -> Doc
 360 doc f = Doc $ return $ Document f
 361
 362 -- | '(<>)' is the concatenation operator for 'Doc's
 363 (<>) :: Doc -> Doc -> Doc
 364 -- | @a '<?>' b@ is @a@ if it is not empty, else @b@.
 365 (<?>) :: Doc -> Doc -> Doc
 366 -- | @a '<+>' b@ is @a@ followed by a space, then @b@.
 367 (<+>) :: Doc -> Doc -> Doc
 368 -- | @a '$$' b@ is @a@ above @b@.
 369 ($$) :: Doc -> Doc -> Doc
 370 -- a then b
 371 Doc a <> Doc b =
 372    Doc $ do ad <- a
 373             case ad of
 374                 Empty -> b
 375                 Document af ->
 376                     do bd <- b
 377                        return $ Document (\s -> af $ case bd 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 $ do ad <- a
 384              case ad of
 385                  Empty -> return Empty
 386                  Document af ->
 387                      do bd <- b
 388                         return $ Document (\s -> af $ case bd of
 389                                                           Empty -> s
 390                                                           Document bf -> bf s)
 391
 392 -- a then space then b
 393 Doc a <+> Doc b =
 394     Doc $ do ad <- a
 395              case ad of
 396                  Empty -> b
 397                  Document af ->
 398                      do bd <- b
 399                         return $ Document (\s -> af $ case bd of
 400                                                           Empty -> s
 401                                                           Document bf ->
 402                                                               space_p:bf s)
 403
 404 -- a above b
 405 Doc a $$ Doc b =
 406    Doc $ do ad <- a
 407             case ad of
 408                 Empty -> b
 409                 Document af ->
 410                     do bd <- b
 411                        st <- ask
 412                        let pf = current_prefix st
 413                            sf = lineColorS $ printers st
 414                        return $ Document (\s -> af
 415                                               $ case bd of
 416                                                     Empty -> s
 417                                                     Document bf ->
 418                                                         sf (newline_p:pf (bf s)))
 419
 420 -- | 'vcat' piles vertically a list of 'Doc's.
 421 vcat :: [Doc] -> Doc
 422 vcat [] = empty
 423 vcat ds = foldr1 ($$) ds
 424
 425 -- | 'vsep' piles vertically a list of 'Doc's leaving a blank line between each.
 426 vsep :: [Doc] -> Doc
 427 vsep [] = empty
 428 vsep ds = foldr1 ($$) $ intersperse (text "") ds
 429
 430 -- | 'hcat' concatenates (horizontally) a list of 'Doc's
 431 hcat :: [Doc] -> Doc
 432 hcat [] = empty
 433 hcat ds = foldr1 (<>) ds
 434 \end{code}
 435