A Document is at heart ShowS from the prelude
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 (text "foo") makes the Doc that prints
"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.:

  (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" ++ "")))

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

This code was made generic in the element type by Juliusz Chroboczek.
\begin{code}
module Printer (Printable, PrintableString, Doc, Printers(..),
                Printer, PChar, Color(..),
                printableFromChar, printableStringFromString,
                printableStringFromPS,
                hPutPrintChar, putPrintChar, hPutPrintStr, putPrintStr, 
                renderWith,
                colorText, invisibleText, text,
                blueText, redText, greenText,
                colorText', invisibleText', text',
                colourPrinters, escapedPrinters, simplePrinters,
                empty, (<>), (<+>), ($$), vcat) where

import Control.Monad.Reader (Reader, runReader, ask)
import Char (isAscii, isPrint, isSpace, ord, intToDigit)
import External ( getTermNColors )

import Maybe (isJust, fromJust)
import IO (Handle, stdout, hPutChar, hPutStr)
import System ( getEnv )
import System.IO.Unsafe ( unsafePerformIO )

import FastPackedString(PackedString, packString, hPutPS, unpackPS, anyPS)

class Printable a where
    printableFromChar :: Char -> a
    hPutPrintChar :: Handle -> a -> IO ()
    hPutPrintStr :: Handle -> [a] -> IO ()
    printableStringFromPS :: PackedString -> [a]
    mapPrintable :: (Char -> Maybe String) -> [a] -> [a]

    hPutPrintStr _ [] = return ()
    hPutPrintStr handle (c : cs) =
        hPutPrintChar handle c >> hPutPrintStr handle cs
    printableStringFromPS =  printableStringFromString . unpackPS

putPrintChar :: Printable a => a -> IO ()
putPrintChar = hPutPrintChar stdout

putPrintStr :: Printable a => PrintableString a -> IO()
putPrintStr = hPutPrintStr stdout

instance Printable Char where
    printableFromChar = id
    hPutPrintChar = hPutChar
    hPutPrintStr = hPutStr
    mapPrintable f p = concat $ map f' p
        where f' = \x -> case (f x) of
                        Nothing -> [x]
                        Just l -> l

space, newline :: Printable a => a
space = printableFromChar ' '
newline = printableFromChar '\n'

instance Printable PackedString where
    printableFromChar c = packString [c]
    hPutPrintChar = hPutPS
    printableStringFromPS s = [s]
    mapPrintable f l = map map1 l
        where map1 p =
                  if anyPS (isJust . f) p
                     then packString (concat $ map f' $ unpackPS p)
                     else p
              f' = \x -> case (f x) of
                         Nothing -> [x]
                         Just s -> s
    
-- Both of the above are inefficient (the latter because it calls
-- malloc in printableFromChar).  PChar combines the two.

data PChar = C !Char | PS !PackedString

instance Printable PChar where
    printableFromChar c = C c
    hPutPrintChar h (C c) = hPutChar h c
    hPutPrintChar h (PS ps) = hPutPS h ps
    -- in principle useless, but why not specialise it
    hPutPrintStr h = put
        where put [] = return ()
              put ((C c) : cs) = hPutChar h c >> put cs
              put ((PS ps) : cs) = hPutPS h ps >> put cs
    printableStringFromPS ps = [PS ps]
    mapPrintable f l = mp l
        where mp [] = []
              mp (h@(C c) : cs) =
                  if isJust(f c)
                     then (map C $ fromJust(f c)) ++ (mp cs)
                     else h : (mp cs)
              mp (h@(PS ps) : cs) =
                  if anyPS (isJust . f) ps
                     then concat (map (\c -> (map C (f' c))) (unpackPS ps)) ++ 
                         (mp cs)
                     else h : (mp cs)
              f' = \x -> case (f x) of
                         Nothing -> [x]
                         Just s -> s

type PrintableString a = [a]

printableStringFromString :: Printable a => String -> PrintableString a
printableStringFromString = map printableFromChar

type Doc a = Reader (Printers a) (Document a)

data Printers a = Printers {colorP :: !(Color -> Printer a),
                            invisibleP :: !(Printer a),
                            defP :: !(Printer a)
                           }
type Printer a = PrintableString a -> Doc a

data Color = Blue | Red | Green

data Document a = Doc (PrintableString a -> PrintableString a)
                | Empty

renderWith :: Printers a -> Doc a -> PrintableString a
renderWith ps d = case runReader d ps of
                      Empty -> []
                      Doc f -> f []

text, invisibleText, blueText, redText, greenText
    :: Printable a => String -> Doc a
text = text' . printableStringFromString
invisibleText = invisibleText' . printableStringFromString
blueText = colorText Blue
redText = colorText Red
greenText = colorText Green

colorText :: Printable a => Color -> String -> Doc a
colorText c = colorText' c . printableStringFromString

text', invisibleText' :: Printable a => PrintableString a -> Doc a
text' x = do ps <- ask
             defP ps x
colorText' :: Printable a => Color -> PrintableString a -> Doc a
colorText' c x = do ps <- ask
                    colorP ps c x
invisibleText' x = ask >>= (`invisibleP` x)

colourPrinters :: Printable a => IO (Printers a)

realColourPrinters, escapedPrinters, simplePrinters :: 
    Printable a => Printers a
realColourPrinters  = Printers { colorP = colorPrinter,
                                 invisibleP = invisiblePrinter,
                                 defP = escapedPrinter
                               }
escapedPrinters = Printers { colorP = \_ -> escapedPrinter,
                             invisibleP = invisiblePrinter,
                             defP = escapedPrinter
                           }
simplePrinters  = Printers { colorP = \_ -> simplePrinter,
                             invisibleP = simplePrinter,
                             defP = simplePrinter
                           }

escapedPrinter, simplePrinter :: Printable a => Printer a
colorPrinter :: Printable a => Color -> Printer a
invisiblePrinter :: Printable a => Printer a
escapedPrinter x = doc (\s -> escape s x)
simplePrinter  x = doc (\s -> x ++ s)
colorPrinter Blue  x = doc (\s -> (make_blue  x) ++ s)
colorPrinter Red   x = doc (\s -> (make_red   x) ++ s)
colorPrinter Green x = doc (\s -> (make_green x) ++ s)
invisiblePrinter _ = doc (\s -> s)

colourPrinters = do num_colors <- getTermNColors
                    if num_colors > 4 then return realColourPrinters
                                      else return escapedPrinters

infixl 6 <>
infixl 6 <+>
infixl 5 $$

empty :: Doc a
empty = return Empty
doc :: (PrintableString a -> PrintableString a) -> Doc a
doc f = return $ Doc f

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

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

a $$ b = do ad <- a
            case ad of
                Empty -> b
                Doc af -> do bd <- b
                             return $ Doc (\s -> af $ case bd of
                                                          Empty -> s
                                                          Doc bf -> newline:bf s)

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

-- escape assumes the input is in ['\0'..'\255']
escape :: 
    Printable a => PrintableString a -> PrintableString a -> PrintableString a
escape s x = (mapPrintable escape1 x) ++ s
    where escape1 '\x1B' = Just (make_blue (printableStringFromString "^["))
          escape1 c | (isAscii c || trustIsPrint) && (isPrint c || isSpace c) = Nothing
          escape1 c = let (q, r) = quotRem (ord c) 16
                          in Just $ make_blue $
                             printableStringFromString
                             ['\\', intToDigit q, intToDigit r]

trustIsPrint :: Bool
trustIsPrint =
    unsafePerformIO $ do
        n <- getEnv "DARCS_USE_ISPRINT" `catch` \_ -> return "0"
        return $ n /= "0"

make_blue :: 
    Printable a => PrintableString a -> PrintableString a
make_blue x = psfs "\x1B[01;34m" ++ x ++ psfs "\x1B[00m"
    where psfs = printableStringFromString

make_red :: 
    Printable a => PrintableString a -> PrintableString a
make_red x = psfs "\x1B[01;31m" ++ x ++ psfs "\x1B[00m"
    where psfs = printableStringFromString

make_green :: 
    Printable a => PrintableString a -> PrintableString a
make_green x = psfs "\x1B[01;32m" ++ x ++ psfs "\x1B[00m"
    where psfs = printableStringFromString
\end{code}