A Document is at heart ShowS from the prelude
\htmladdnormallink{http://www.haskell.org/onlinereport/standard-prelude.html#\$tShowS}

Essentially, if you give a Doc a string it'll print out whatever it
wants followed by that string. So \verb!(text "foo")! makes the Doc that
prints \verb!"foo"! followed by its argument. The combinator names are taken
from Text.PrettyPrint.HughesPJ, although the behaviour of the two libraries is
slightly different.

The advantage of Printer over simple string appending/concatenating is
that the appends end up associating to the right, e.g.:

\begin{verbatim}
  (text "foo" <> text "bar") <> (text "baz" <> text "quux") ""
= \s -> (text "foo" <> text "bar") ((text "baz" <> text "quux") s) ""
= (text "foo" <> text "bar") ((text "baz" <> text "quux") "")
= (\s -> (text "foo") (text "bar" s)) ((text "baz" <> text "quux") "")
= text "foo" (text "bar" ((text "baz" <> text "quux") ""))
= (\s -> "foo" ++ s) (text "bar" ((text "baz" <> text "quux") ""))
= "foo" ++ (text "bar" ((text "baz" <> text "quux") ""))
= "foo" ++ ("bar" ++ ((text "baz" <> text "quux") ""))
= "foo" ++ ("bar" ++ ((\s -> text "baz" (text "quux" s)) ""))
= "foo" ++ ("bar" ++ (text "baz" (text "quux" "")))
= "foo" ++ ("bar" ++ ("baz" ++ (text "quux" "")))
= "foo" ++ ("bar" ++ ("baz" ++ ("quux" ++ "")))
\end{verbatim}

The Empty alternative comes in because you want
\begin{verbatim}
    text "a" $$ vcat xs $$ text "b"
\end{verbatim}
(\verb!$$! means ``above'', vcat is the list version of \verb!$$!) to be
\verb!"a\nb"! when \verb!xs!  is \verb![]!, but without the concept of an
Empty Document each \verb!$$! would add a \verb!'\n'! and you'd end up with
\verb!"a\n\nb"!. Note that \verb!Empty /= text ""! (the latter would cause two
\verb!'\n'!s).

This code was made generic in the element type by Juliusz Chroboczek.
\begin{code}
module Printer (Printable(..), Doc(Doc,unDoc), Printers, Printers'(..), Printer, Color(..),
                hPutDoc,     hPutDocLn,     putDoc,     putDocLn,
                hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith,
                renderString, renderStringWith, renderPS, renderPSWith,
                renderPSs, renderPSsWith, lineColor,
                prefix, colorText, invisibleText, hiddenText, hiddenPrefix, userchunk, text,
                printable, wrap_text,
                blueText, redText, greenText, magentaText, cyanText,
                unsafeText, unsafeBoth, unsafeBothText, unsafeChar,
                invisiblePS, packedString, unsafePackedString, userchunkPS,
                simplePrinters, invisiblePrinter, simplePrinter,
                doc, empty, (<>), (<?>), (<+>), ($$), vcat, vsep, hcat,
                minus, newline, plus, space, backslash, lparen, rparen,
                parens,
                errorDoc,
               ) where

import Control.Monad.Reader (Reader, runReader, ask, asks, local)
import Data.List (intersperse)
import System.IO (Handle, stdout, hPutStr)
import FastPackedString (PackedString, packString, hPutPS, unpackPS, concatPS)

data Printable = S !String
               | PS !PackedString
               | Both !String !PackedString

space_p, newline_p :: Printable
space_p   = Both " "  (packString " ")
newline_p = S "\n"

space, newline, plus, minus, backslash :: Doc
space     = unsafeBoth " "  (packString " ")
newline   = unsafeChar '\n'
minus     = unsafeBoth "-"  (packString "-")
plus      = unsafeBoth "+"  (packString "+")
backslash = unsafeBoth "\\" (packString "\\")

lparen, rparen :: Doc
lparen = unsafeBoth  "(" (packString "(")
rparen = unsafeBoth ")" (packString ")")

parens :: Doc -> Doc
parens d = lparen <> d <> rparen

errorDoc :: Doc -> a
errorDoc = error . renderStringWith simplePrinters'

putDocWith, putDocLnWith :: Printers -> Doc -> IO ()
putDocWith prs = hPutDocWith prs stdout
putDocLnWith prs = hPutDocLnWith prs stdout

putDoc, putDocLn :: Doc -> IO ()
putDoc = hPutDoc stdout
putDocLn = hPutDocLn stdout

hPutDocWith, hPutDocLnWith :: Printers -> Handle -> Doc -> IO ()
hPutDocWith prs h d = hPrintPrintables h (renderWith (prs h) d)
hPutDocLnWith prs h d = hPutDocWith prs h (d <?> newline)

hPutDoc, hPutDocLn :: Handle -> Doc -> IO ()
hPutDoc = hPutDocWith simplePrinters
hPutDocLn = hPutDocLnWith simplePrinters

hPrintPrintables :: Handle -> [Printable] -> IO ()
hPrintPrintables h = mapM_ (hPrintPrintable h)

hPrintPrintable :: Handle -> Printable -> IO ()
hPrintPrintable h (S ps) = hPutStr h ps
hPrintPrintable h (PS ps) = hPutPS h ps
hPrintPrintable h (Both _ ps) = hPutPS h ps

newtype Doc = Doc { unDoc :: Reader St Document }

data St = St { printers :: !Printers', current_prefix :: !DocumentInternals }
type Printers = Handle -> Printers'
data Printers' = Printers {colorP :: !(Color -> Printer),
                           invisibleP :: !Printer,
                           hiddenP :: !Printer,
                           userchunkP :: !Printer,
                           defP :: !Printer,
                           lineColorT :: !(Color -> Doc -> Doc),
                           lineColorS :: !DocumentInternals
                          }
type Printer = Printable -> Reader St Document

data Color = Blue | Red | Green | Cyan | Magenta

type DocumentInternals = [Printable] -> [Printable]
data Document = Document DocumentInternals
              | Empty

renderString :: Doc -> String
renderString = renderStringWith simplePrinters'

renderStringWith :: Printers' -> Doc -> String
renderStringWith prs d = concatMap toString $ renderWith prs d
    where toString (S s) = s
          toString (PS ps) = unpackPS ps
          toString (Both s _) = s

renderPS :: Doc -> PackedString
renderPS = renderPSWith simplePrinters'

renderPSs :: Doc -> [PackedString]
renderPSs = renderPSsWith simplePrinters'

renderPSWith :: Printers' -> Doc -> PackedString
renderPSWith prs d = concatPS $ renderPSsWith prs d

renderPSsWith :: Printers' -> Doc -> [PackedString]
renderPSsWith prs d = map toPS $ renderWith prs d
    where toPS (S s) = packString s
          toPS (PS ps) = ps
          toPS (Both _ ps) = ps

renderWith :: Printers' -> Doc -> [Printable]
renderWith ps (Doc d) = case runReader d (init_state ps) of
                        Empty -> []
                        Document f -> f []

init_state :: Printers' -> St
init_state prs = St { printers = prs, current_prefix = id }

prefix :: String -> Doc -> Doc
prefix s (Doc d) =
    Doc $ local (\st -> st { current_prefix = current_prefix st . (p:) })
                   (do d' <- d
                       case d' of
                           Document d'' -> return $ Document $ (p:) . d''
                           Empty -> return Empty)
    where p = S s

lineColor :: Color -> Doc -> Doc
lineColor c d =
    Doc $ do pr <- asks printers
             unDoc $ lineColorT pr c d

hiddenPrefix :: String -> Doc -> Doc
hiddenPrefix s (Doc d) =
    Doc $ do pr <- asks printers
             let p = S (renderStringWith pr $ hiddenText s)
             local (\st -> st { current_prefix = current_prefix st . (p:) })
                       (do d' <- d
                           case d' of
                             Document d'' -> return $ Document $ (p:) . d''
                             Empty -> return Empty)

unsafeBoth :: String -> PackedString -> Doc
unsafeBoth s ps = Doc $ simplePrinter (Both s ps)

unsafeBothText :: String -> Doc
unsafeBothText s = Doc $ simplePrinter (Both s (packString s))

packedString, unsafePackedString, invisiblePS, userchunkPS :: PackedString -> Doc
packedString = printable . PS
unsafePackedString = Doc . simplePrinter . PS
invisiblePS = invisiblePrintable . PS
userchunkPS = userchunkPrintable . PS

unsafeChar :: Char -> Doc
unsafeChar = unsafeText . return

text, unsafeText, invisibleText, hiddenText, userchunk, blueText, redText, greenText, magentaText, cyanText :: String -> Doc
text = printable . S
unsafeText = Doc . simplePrinter . S
invisibleText = invisiblePrintable . S
hiddenText = hiddenPrintable . S
userchunk = userchunkPrintable . S
blueText = colorText Blue
redText = colorText Red
greenText = colorText Green
magentaText = colorText Magenta
cyanText = colorText Cyan

colorText :: Color -> String -> Doc
colorText c = mkColorPrintable c . S

wrap_text :: Int -> String -> Doc
wrap_text n s =
    vcat $ map text $ reverse $ "": (foldl add_to_line [] $ words s)
  where add_to_line [] a = [a]
        add_to_line ("":d) a = (a:d)
        add_to_line (l:ls) new | length l + length new > n = new:l:ls
        add_to_line (l:ls) new = (l ++ " " ++ new):ls

printable, invisiblePrintable, hiddenPrintable, userchunkPrintable :: Printable -> Doc
printable x = Doc $ do st <- ask
                       defP (printers st) x
mkColorPrintable :: Color -> Printable -> Doc
mkColorPrintable c x = Doc $ do st <- ask
                                colorP (printers st) c x
invisiblePrintable x = Doc $ do st <- ask
                                invisibleP (printers st) x
hiddenPrintable x = Doc $ do st <- ask
                             hiddenP (printers st) x
userchunkPrintable x = Doc $ do st <- ask
                                userchunkP (printers st) x

simplePrinters :: Printers
simplePrinters _ = simplePrinters'

simplePrinters' :: Printers'
simplePrinters'  = Printers { colorP = const simplePrinter,
                              invisibleP = simplePrinter,
                              hiddenP = invisiblePrinter,
                              userchunkP = simplePrinter,
                              defP = simplePrinter,
                              lineColorT = const id,
                              lineColorS = id
                            }

simplePrinter :: Printer
invisiblePrinter :: Printer
simplePrinter x = unDoc $ doc (\s -> x:s)
invisiblePrinter _ = unDoc empty

infixr 6 <>
infixr 6 <+>
infixr 5 $$

empty :: Doc
empty = Doc $ return Empty
doc :: ([Printable] -> [Printable]) -> Doc
doc f = Doc $ return $ Document f

(<>), (<?>), (<+>), ($$) :: Doc -> Doc -> Doc
-- a then b
Doc a <> Doc b =
   Doc $ do ad <- a
            case ad of
                Empty -> b
                Document af ->
                    do bd <- b
                       return $ Document (\s -> af $ case bd of
                                                         Empty -> s
                                                         Document bf -> bf s)

-- empty if a empty, else a then b
Doc a <?> Doc b =
    Doc $ do ad <- a
             case ad of
                 Empty -> return Empty
                 Document af ->
                     do bd <- b
                        return $ Document (\s -> af $ case bd of
                                                          Empty -> s
                                                          Document bf -> bf s)

-- a then space then b
Doc a <+> Doc b =
    Doc $ do ad <- a
             case ad of
                 Empty -> b
                 Document af ->
                     do bd <- b
                        return $ Document (\s -> af $ case bd of
                                                          Empty -> s
                                                          Document bf ->
                                                              space_p:bf s)

-- a above b
Doc a $$ Doc b =
   Doc $ do ad <- a
            case ad of
                Empty -> b
                Document af ->
                    do bd <- b
                       st <- ask
                       let pf = current_prefix st
                           sf = lineColorS $ printers st
                       return $ Document (\s -> af
                                              $ case bd of
                                                    Empty -> s
                                                    Document bf ->
                                                        sf (newline_p:pf (bf s)))

vcat :: [Doc] -> Doc
vcat [] = empty
vcat ds = foldr1 ($$) ds

vsep :: [Doc] -> Doc
vsep [] = empty
vsep ds = foldr1 ($$) $ intersperse (text "") ds

hcat :: [Doc] -> Doc
hcat [] = empty
hcat ds = foldr1 (<>) ds
\end{code}