[add Doc directly to darcs repository
John Meacham <john@repetae.net>**20100722011951
 Ignore-this: dba37e7f9d9da717278767ef48dd2120
] hunk ./Makefile.am 78
-	test -d src/Doc || darcs get --partial http://repetae.net/repos/Doc --repodir=src/Doc
adddir ./src/Doc
addfile ./src/Doc/Attr.hs
hunk ./src/Doc/Attr.hs 1
+module Doc.Attr(Attr(..), attrEmpty, ansi, html)  where
+
+import Doc.DocLike
+
+
+data Attr d = Attr {
+   attrBold :: d -> d,
+   attrColor :: String -> d -> d
+}
+
+attrEmpty = Attr { attrBold = id, attrColor = \_ -> id }
+
+
+ansi,html :: DocLike d => (String -> d) -> Attr d
+
+ansi oob = attrEmpty {
+    attrBold = \x -> oob "\27[1m" <> x <> oob attrClear,
+    attrColor = \c x -> oob ("\27[" ++ ansiColor c ++ "m") <> x <> oob attrClear
+        }
+
+html oob = attrEmpty {
+    attrBold = \x -> oob "<b style=\"color: white\">" <> x <> oob "</b>",
+    attrColor = \c x -> oob ("<span style=\"color: " ++ c ++ ";\">") <> x <> oob "</span>"
+        }
+
+
+ansiColor "black" = "0;30"
+ansiColor "red"  = "0;31"
+ansiColor "green"  = "0;32"
+ansiColor "yellow"  = "0;33"
+ansiColor "blue"  = "0;94"
+ansiColor "magenta" = "0;35"
+ansiColor "cyan"  = "0;36"
+ansiColor "white" = "0;37"
+ansiColor "lightgreen"  = "0;92"
+ansiColor "lightred"  = "0;91"
+--ansiColor "brightblue"  = "0;94"
+ansiColor _ = "0"
+
+attrClear = "\27[0m"
+
+
addfile ./src/Doc/Chars.hs
hunk ./src/Doc/Chars.hs 1
+-- | A variety of useful constant documents representing many unicode characters.
+
+module Doc.Chars where
+
+import Char(chr)
+import Doc.DocLike
+
+ulCorner, llCorner, urCorner, lrCorner, rTee, lTee, bTee, tTee, hLine,
+ vLine, plus, s1, s9, diamond, ckBoard, degree, plMinus, bullet, lArrow,
+ rArrow, dArrow, uArrow, board, lantern, block, s3, s7, lEqual, gEqual,
+ pi, nEqual, sterling, coloncolon, alpha, beta, lambda, forall, exists,
+ box, bot, bottom, top, pI, lAmbda, star, elem, notElem, and, or, sqoparen, sqcparen  :: TextLike a => a
+
+ulCorner  = char $ chr 0x250C
+llCorner = char $ chr 0x2514
+urCorner = char $ chr 0x2510
+lrCorner = char $ chr 0x2518
+rTee     = char $ chr 0x2524
+lTee     = char $ chr 0x251C
+bTee     = char $ chr 0x2534
+tTee     = char $ chr 0x252C
+hLine    = char $ chr 0x2500
+vLine    = char $ chr 0x2502
+plus     = char $ chr 0x253C
+s1       = char $ chr 0x23BA -- was: 0xF800
+s9       = char $ chr 0x23BD -- was: 0xF804
+diamond  = char $ chr 0x25C6
+ckBoard  = char $ chr 0x2592
+degree   = char $ chr 0x00B0
+plMinus  = char $ chr 0x00B1
+bullet   = char $ chr 0x00B7
+lArrow   = char $ chr 0x2190
+rArrow   = char $ chr 0x2192
+dArrow   = char $ chr 0x2193
+uArrow   = char $ chr 0x2191
+board    = char $ chr 0x2591
+lantern  = char $ chr 0x256C
+block    = char $ chr 0x2588
+s3       = char $ chr 0x23BB -- was: 0xF801
+s7       = char $ chr 0x23BC -- was: 0xF803
+lEqual   = char $ chr 0x2264
+gEqual   = char $ chr 0x2265
+pi       = char $ chr 0x03C0
+nEqual   = char $ chr 0x2260
+sterling = char $ chr 0x00A3
+
+coloncolon = char $ chr 0x2237  -- ∷
+
+alpha    = char $ chr 0x03b1  -- α
+beta     = char $ chr 0x03b2  -- β
+
+
+lambda   = char $ chr 0x03bb  -- λ
+forall   = char $ chr 0x2200  -- ∀
+exists   = char $ chr 0x2203  -- ∃
+box      = char $ chr 0x25a1  -- □
+
+bot      = char $ chr 0x22a5  -- ⊥
+bottom   = char $ chr 0x22a5  -- ⊥
+top      = char $ chr 0x22a4  -- T
+pI       = char $ chr 0x03a0
+lAmbda   = char $ chr 0x039b  -- Λ  (capital λ)
+and      = char $ chr 0x2227  -- ∧
+or       = char $ chr 0x2228  -- ∨
+star     = char $ chr 0x22c6
+elem     = char $ chr 0x2208  -- ∈
+notElem  = char $ chr 0x2209
+
+sqoparen = char $ chr 0x3014  -- 〔
+sqcparen = char $ chr 0x3015  --  〕
+
addfile ./src/Doc/DocLike.hs
hunk ./src/Doc/DocLike.hs 1
+{-# LANGUAGE UndecidableInstances,OverlappingInstances #-}
+module Doc.DocLike where
+
+-- arch-tag: a88f19fb-e18d-475f-b6d1-8da78676261a
+
+import Data.Monoid
+import Control.Monad.Reader()
+import qualified Text.PrettyPrint.HughesPJ as P
+
+infixr 5 <$> -- ,<//>,<$>,<$$>
+infixr 6 <>
+infixr 6 <+>
+
+
+class TextLike a where
+    empty :: a
+    text :: String -> a
+    --string :: String -> a
+    char :: Char -> a
+    --char '\n' = string "\n"
+    char x = text [x]
+    empty = text ""
+
+
+class (TextLike a) => DocLike a where
+    (<>) :: a -> a -> a
+    (<+>) :: a -> a -> a
+    (<$>) :: a -> a -> a
+    hsep :: [a] -> a
+    hcat :: [a] -> a
+    vcat :: [a] -> a
+    tupled :: [a] -> a
+    list :: [a] -> a
+    semiBraces :: [a] -> a
+    enclose :: a -> a -> a -> a
+    encloseSep :: a -> a -> a -> [a] -> a
+
+    hcat [] = empty
+    hcat xs = foldr1 (<>) xs
+    hsep [] = empty
+    hsep xs = foldr1 (<+>) xs
+    vcat [] = empty
+    vcat xs = foldr1 (\x y -> x <> char '\n' <> y) xs
+    x <+> y = x <> char ' ' <> y
+    x <$> y = x <> char '\n' <> y
+    encloseSep l r s ds = enclose l r (hcat $ punctuate s ds)
+    enclose l r x   = l <> x <> r
+    list            = encloseSep lbracket rbracket comma
+    tupled          = encloseSep lparen   rparen  comma
+    semiBraces      = encloseSep lbrace   rbrace  semi
+
+
+------------------------
+-- Basic building blocks
+------------------------
+
+tshow :: (Show a,DocLike b) => a -> b
+tshow x = text (show x)
+
+
+
+lparen,rparen,langle,rangle,
+    lbrace,rbrace,lbracket,rbracket,squote,
+    dquote,semi,colon,comma,space,dot,backslash,equals
+    :: TextLike a => a
+lparen          = char '('
+rparen          = char ')'
+langle          = char '<'
+rangle          = char '>'
+lbrace          = char '{'
+rbrace          = char '}'
+lbracket        = char '['
+rbracket        = char ']'
+
+squote          = char '\''
+dquote          = char '"'
+semi            = char ';'
+colon           = char ':'
+comma           = char ','
+space           = char ' '
+dot             = char '.'
+backslash       = char '\\'
+equals          = char '='
+
+
+squotes x = enclose squote squote x
+dquotes x = enclose dquote dquote x
+parens x = enclose lparen rparen x
+braces x = enclose lbrace rbrace x
+brackets x = enclose lbracket rbracket x
+angles x = enclose langle rangle x
+
+-----------------------------------------------------------
+-- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]
+-----------------------------------------------------------
+punctuate _ []      = []
+punctuate _ [d]     = [d]
+punctuate p (d:ds)  = (d <> p) : punctuate p ds
+
+------------------
+-- String instance
+------------------
+instance TextLike String where
+    empty = ""
+    text x = x
+
+instance TextLike Char where
+    empty = error "TextLike: empty char"
+    char x = x
+    text [ch] = ch
+    text _ = error "TextLike: string to char"
+
+instance DocLike String where
+    a <> b = a ++ b
+    a <+> b = a ++ " " ++ b
+
+
+instance TextLike ShowS where
+    empty = id
+    text x = (x ++)
+    char c = (c:)
+
+instance DocLike ShowS where
+    a <> b = a . b
+
+instance (TextLike a, Monad m) => TextLike (m a) where
+    empty = return empty
+    char x = return (char x)
+    text x = return (text x)
+
+
+instance (DocLike a, Monad m,TextLike (m a)) => DocLike (m a) where
+    a <$> b = do
+        a <- a
+        b <- b
+        return (a <$> b)
+    a <> b = do
+        a <- a
+        b <- b
+        return (a <> b)
+    a <+> b = do
+        a <- a
+        b <- b
+        return (a <+> b)
+    vcat xs = sequence xs >>= return . vcat
+    hsep xs = sequence xs >>= return . hsep
+
+---------------------
+-- HughesPJ instances
+---------------------
+
+instance TextLike P.Doc where
+    empty = P.empty
+    text = P.text
+    char = P.char
+
+instance Monoid P.Doc where
+    mappend = (P.<>)
+    mempty = P.empty
+    mconcat = P.hcat
+
+instance DocLike P.Doc where
+    (<>) = (P.<>)
+    (<+>) = (P.<+>)
+    (<$>) = (P.$$)
+    hsep = P.hsep
+    vcat = P.vcat
+
+    --brackets = P.brackets
+    --parens = P.parens
+
+--------
+-- simple instances to allow distribution of an environment
+--------
+--instance Monoid a => Monoid (b -> a) where
+--    mempty = \_ -> mempty
+--    mappend x y = \a -> mappend (x a) (y a)
+--    mconcat xs = \a -> mconcat (map ($ a) xs)
+--
+--instance (DocLike a, Monoid (b -> a)) => DocLike (b -> a) where
+--    parens x = \a -> parens (x a)
+--    (<+>) x y = \a -> x a <+> y a
+
addfile ./src/Doc/PPrint.hs
hunk ./src/Doc/PPrint.hs 1
+
+-- | A Pretty printing class using multiparameter type classes for
+-- maximal generality with some useful instances.
+--
+-- the pprinted type comes as the last argument so newtype deriving can be used
+-- in more places.
+
+module Doc.PPrint where
+
+import Doc.DocLike
+import qualified Data.Map as Map
+
+{-
+ - some useful fixities for comparison
+ -
+ - application left 10
+ - infixr 9  .
+ - infixr 8  ^, ^^, **
+ - infixl 7  *  , /, `quot`, `rem`, `div`, `mod`
+ - infixl 6  +, -
+ - infixr 5  :
+ - infix  4  ==, /=, <, <=, >=, >
+ - infixr 3  &&
+ - infixr 2  ||
+ - infixl 1  >>, >>=
+ - infixr 1  =<<
+ - infixr 0  $, $!, `seq`
+ -
+ -}
+
+data Assoc = AssocLeft | AssocRight | AssocNone
+    deriving(Eq,Ord,Show)
+
+class DocLike d => PPrint d a  where
+    pprint ::  a -> d
+    pprintAssoc :: Assoc -> Int -> a -> d
+
+    pprintAssoc _ _ a = pprint a
+    pprint a = pprintAssoc AssocNone (-1) a
+
+
+    pplist    ::  [a] -> d
+    pplist    xs = brackets (hcat (punctuate comma (map pprint xs)))
+
+pprintParen :: PPrint d a => a -> d
+pprintParen = pprintPrec 11
+
+pprintPrec n a = pprintAssoc AssocNone n  a
+
+instance PPrint d a => PPrint d [a] where
+    pprint  = pplist
+
+instance DocLike d => PPrint d Char where
+  pprint  = char
+  pplist  = text
+
+instance DocLike d => PPrint d Integer where
+  pprint  = tshow
+
+instance DocLike d => PPrint d Int where
+  pprint  = tshow
+
+instance DocLike d => PPrint d Float where
+  pprint  = tshow
+
+instance DocLike d => PPrint d Double where
+  pprint  = tshow
+
+instance DocLike d => PPrint d () where
+    pprint () = text "()"
+
+instance (PPrint d a, PPrint d b) => PPrint d (a,b) where
+  pprint (x,y) = parens (hsep [pprint x <> comma, pprint y])
+
+checkAssoc a1 n1 a2 n2 | n2 < n1 = id
+                       | n1 == n2 && a1 == a2 && a1 /= AssocNone = id
+                       | otherwise = parens
+
+checkAssocApp a n p = checkAssoc AssocLeft 10 a n p
+
+pprintBinary a1 n1 a2 n2 x1 b x2 = checkAssoc a1 n1 a2 n2 $ pprintAssoc l n1 x1 <+> b <+> pprintAssoc r n1 x2 where
+    l = if a1 == AssocLeft then AssocLeft else AssocNone
+    r = if a1 == AssocRight then AssocRight else AssocNone
+
+instance (PPrint d a, PPrint d b) => PPrint d (Either a b) where
+  pprintAssoc a n (Left x)  = checkAssocApp a n $ text "Left" <+> pprintPrec 10 x
+  pprintAssoc a n (Right x) = checkAssocApp a n $ text "Right" <+> pprintPrec 10 x
+
+instance (PPrint d a, PPrint d b, PPrint d c) => PPrint d (a,b,c) where
+  pprint (x,y,z) = parens (hsep [pprint x <> comma,
+                                pprint y <> comma,
+                                pprint z])
+
+instance (PPrint d a, PPrint d b) => PPrint d (Map.Map a b) where
+    pprint m = vcat [ pprint x <+> text "=>" <+> pprint y | (x,y) <- Map.toList m]
+
+
addfile ./src/Doc/Pretty.hs
hunk ./src/Doc/Pretty.hs 1
+{-# OPTIONS -fno-monomorphism-restriction #-}
+-----------------------------------------------------------
+-- Daan Leijen (c) 2000, http://www.cs.uu.nl/~daan
+-- modified by John Meacham 2003
+--
+--
+-- Pretty print module based on Philip Wadlers "prettier printer"
+--      "A prettier printer"
+--      Draft paper, April 1997, revised March 1998.
+--      http://cm.bell-labs.com/cm/cs/who/wadler/papers/prettier/prettier.ps
+--
+-- Haskell98 compatible
+-----------------------------------------------------------
+
+-- | Modification od Daan Leijens pretty printer. main changes are use of
+-- Doc.DocLike framework and the addition of out-of-band data for html tags
+-- or ansi escape codes
+
+module Doc.Pretty
+        ( Doc
+
+        , putDoc, hPutDoc
+        , putDocM, putDocMLn
+        --, (<>)
+        --, (<+>)
+        , (</>), (<//>)
+        --, (<$>)
+        , (<$$>)
+
+        , sep, fillSep, hsep, vsep
+        , cat, fillCat, hcat, DocLike.vcat
+
+        , align, hang, indent
+        , fill, fillBreak
+        , errorDoc, failDoc
+
+       -- , string, bool, int, integer, float, double, rational
+
+        , softline, softbreak
+        , line, linebreak, nest, group
+        , column, nesting, width
+
+        , SimpleDoc(..)
+        , renderPretty, renderCompact
+        , displayS, displayIO, displayM
+        , textProc, oob
+        ) where
+
+import IO      (Handle,hPutStr,hPutChar,stdout)
+import Doc.DocLike hiding(empty)
+import qualified Doc.DocLike as DocLike
+import Data.Monoid
+
+infixr 5 </>,<//>,<$>,<$$>
+--infixr 6 <>,<+>
+
+
+-----------------------------------------------------------
+-- list, tupled and semiBraces pretty print a list of
+-- documents either horizontally or vertically aligned.
+-----------------------------------------------------------
+
+encloseSep left right sep ds
+    = case ds of
+        []  -> left <> right
+        [d] -> left <> d <> right
+        _   -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right)
+
+
+
+errorDoc :: Doc -> a
+errorDoc = error . ('\n':) . show
+
+failDoc :: Monad m => Doc -> m a
+failDoc = fail . ('\n':) . show
+
+-----------------------------------------------------------
+-- high-level combinators
+-----------------------------------------------------------
+sep             = group . vsep
+fillSep         = fold (</>)
+--hsep            = fold (<+>)
+vsep            = fold (Doc.Pretty.<$>)
+
+cat             = group . Doc.Pretty.vcat
+fillCat         = fold (<//>)
+--hcat            = fold (<>)
+vcat            = fold (<$$>)
+
+fold f []       = empty
+fold f ds       = foldr1 f ds
+
+instance Monoid Doc where
+    mempty = Doc.Pretty.empty
+    mappend = beside
+    mconcat = fold beside
+
+instance TextLike Doc where
+    empty = Doc.Pretty.empty
+    text = mytext
+    char x = mychar x
+
+instance DocLike Doc where
+    x <> y = x `beside` y
+    x <+> y = x <> space <> y
+    encloseSep = Doc.Pretty.encloseSep
+    vcat = Doc.Pretty.vcat
+    --hcat = Doc.Pretty.hcat
+    --hsep = Doc.Pretty.hsep
+
+--x <> y          = x `beside` y
+--x <+> y         = x <> space <> y
+x </> y         = x <> softline <> y
+x <//> y        = x <> softbreak <> y
+x <$> y         = x <> line <> y
+x <$$> y        = x <> linebreak <> y
+
+softline        = group line
+softbreak       = group linebreak
+
+
+
+-----------------------------------------------------------
+-- Combinators for prelude types
+-----------------------------------------------------------
+
+-- string is like "text" but replaces '\n' by "line"
+string ""       = empty
+string ('\n':s) = line <> string s
+string s        = case (span (/='\n') s) of
+                    (xs,ys) -> text xs <> string ys
+
+
+bool :: Bool -> Doc
+bool b          = text (show b)
+
+int :: Int -> Doc
+int i           = text (show i)
+
+integer :: Integer -> Doc
+integer i       = text (show i)
+
+float :: Float -> Doc
+float f         = text (show f)
+
+double :: Double -> Doc
+double d        = text (show d)
+
+rational :: Rational -> Doc
+rational r      = text (show r)
+
+
+
+
+-----------------------------------------------------------
+-- semi primitive: fill and fillBreak
+-----------------------------------------------------------
+fillBreak f x   = width x (\w ->
+                  if (w > f) then nest f linebreak
+                             else text (spaces (f - w)))
+
+fill f d        = width d (\w ->
+                  if (w >= f) then empty
+                              else text (spaces (f - w)))
+
+width d f       = column (\k1 -> d <> column (\k2 -> f (k2 - k1)))
+
+
+-----------------------------------------------------------
+-- semi primitive: Alignment and indentation
+-----------------------------------------------------------
+indent i d      = hang i (text (spaces i) <> d)
+
+hang i d        = align (nest i d)
+
+align d         = column (\k ->
+                  nesting (\i -> nest (k - i) d))   --nesting might be negative :-)
+
+
+
+-----------------------------------------------------------
+-- Primitives
+-----------------------------------------------------------
+data Doc        = Empty
+                | Char Char             -- invariant: char is not '\n'
+                | Text !Int String      -- invariant: text doesn't contain '\n'
+                | Line !Bool            -- True <=> when undone by group, do not insert a space
+                | Cat Doc Doc
+                | Nest !Int Doc
+                | Union Doc Doc         -- invariant: first lines of first doc longer than the first lines of the second doc
+                | Column  (Int -> Doc)
+                | Nesting (Int -> Doc)
+
+data SimpleDoc  = SEmpty
+                | SChar Char SimpleDoc
+                | SText !Int String SimpleDoc
+                | SLine !Int SimpleDoc
+{-
+class IsDoc z where
+    empty :: z
+    char :: Char -> z
+    text :: String -> z
+    oob :: String -> z
+    textProc :: (Char -> String) -> String -> z
+    line :: z
+    linebreak :: z
+    beside :: z -> z -> z
+    nest :: Int -> z -> z
+    column :: (Int -> z) -> z
+    nesting :: (Int -> z) -> z
+    group :: ()
+  -}
+empty           = Empty
+
+mychar '\n'       = line
+mychar c          = Char c
+
+mytext ""         = Empty
+mytext s          = Text (length s) s
+
+-- | out of band data. This text will appear in the pretty printed output but
+-- won't count towards formatting, as far as pretty printing is concerned, it
+-- is of length 0.
+
+oob :: String -> Doc
+oob "" = Empty
+oob s = Text 0 s
+
+textProc :: (Char -> String) -> String -> Doc
+textProc f "" = Empty
+textProc f s = Text (length s) $ concatMap f s
+
+line            = Line False
+linebreak       = Line True
+
+beside x y      = Cat x y
+nest i x        = Nest i x
+column f        = Column f
+nesting f       = Nesting f
+group :: Doc -> Doc
+group x         = Union (flatten x) x
+
+flatten :: Doc -> Doc
+flatten (Cat x y)       = Cat (flatten x) (flatten y)
+flatten (Nest i x)      = Nest i (flatten x)
+flatten (Line break)    = if break then Empty else Text 1 " "
+flatten (Union x y)     = flatten x
+flatten (Column f)      = Column (flatten . f)
+flatten (Nesting f)     = Nesting (flatten . f)
+flatten other           = other                     --Empty,Char,Text
+
+
+
+-----------------------------------------------------------
+-- Renderers
+-----------------------------------------------------------
+
+-----------------------------------------------------------
+-- renderPretty: the default pretty printing algorithm
+-----------------------------------------------------------
+
+-- list of indentation/document pairs; saves an indirection over [(Int,Doc)]
+data Docs   = Nil
+            | Cons !Int Doc Docs
+
+renderPretty :: Float -> Int -> Doc -> SimpleDoc
+renderPretty rfrac w x
+    = best 0 0 (Cons 0 x Nil)
+    where
+      -- r :: the ribbon width in characters
+      r  = max 0 (min w (round (fromIntegral w * rfrac)))
+
+      -- best :: n = indentation of current line
+      --         k = current column
+      --        (ie. (k >= n) && (k - n == count of inserted characters)
+      best n k Nil      = SEmpty
+      best n k (Cons i d ds)
+        = case d of
+            Empty       -> best n k ds
+            Char c      -> let k' = k+1 in seq k' (SChar c (best n k' ds))
+            Text l s    -> let k' = k+l in seq k' (SText l s (best n k' ds))
+            Line _      -> SLine i (best i i ds)
+            Cat x y     -> best n k (Cons i x (Cons i y ds))
+            Nest j x    -> let i' = i+j in seq i' (best n k (Cons i' x ds))
+            Union x y   -> nicest n k (best n k (Cons i x ds))
+                                      (best n k (Cons i y ds))
+
+            Column f    -> best n k (Cons i (f k) ds)
+            Nesting f   -> best n k (Cons i (f i) ds)
+
+      --nicest :: r = ribbon width, w = page width,
+      --          n = indentation of current line, k = current column
+      --          x and y, the (simple) documents to chose from.
+      --          precondition: first lines of x are longer than the first lines of y.
+      nicest n k x y    | fits width x  = x
+                        | otherwise     = y
+                        where
+                          width = min (w - k) (r - k + n)
+
+
+fits w x        | w < 0         = False
+fits w SEmpty                   = True
+fits w (SChar c x)              = fits (w - 1) x
+fits w (SText l s x)            = fits (w - l) x
+fits w (SLine i x)              = True
+
+
+-----------------------------------------------------------
+-- renderCompact: renders documents without indentation
+--  fast and fewer characters output, good for machines
+-----------------------------------------------------------
+renderCompact :: Doc -> SimpleDoc
+renderCompact x
+    = scan 0 [x]
+    where
+      scan k []     = SEmpty
+      scan k (d:ds) = case d of
+                        Empty       -> scan k ds
+                        Char c      -> let k' = k+1 in seq k' (SChar c (scan k' ds))
+                        Text l s    -> let k' = k+l in seq k' (SText l s (scan k' ds))
+                        Line _      -> SLine 0 (scan 0 ds)
+                        Cat x y     -> scan k (x:y:ds)
+                        Nest j x    -> scan k (x:ds)
+                        Union x y   -> scan k (y:ds)
+                        Column f    -> scan k (f k:ds)
+                        Nesting f   -> scan k (f 0:ds)
+
+
+
+-----------------------------------------------------------
+-- Displayers:  displayS and displayIO
+-----------------------------------------------------------
+displayS :: SimpleDoc -> ShowS
+displayS SEmpty             = id
+displayS (SChar c x)        = showChar c . displayS x
+displayS (SText l s x)      = showString s . displayS x
+displayS (SLine i x)        = showString ('\n':indentation i) . displayS x
+
+displayIO :: Handle -> SimpleDoc -> IO ()
+displayIO handle simpleDoc
+    = display simpleDoc
+    where
+      display SEmpty        = return ()
+      display (SChar c x)   = do{ hPutChar handle c; display x}
+      display (SText l s x) = do{ hPutStr handle s; display x}
+      display (SLine i x)   = do{ hPutStr handle ('\n':indentation i); display x}
+
+displayM :: Monad m => (String -> m ()) -> SimpleDoc -> m ()
+displayM putStr simpleDoc = display simpleDoc where
+      display SEmpty        = return ()
+      display (SChar c x)   = do{ putStr [c]; display x}
+      display (SText l s x) = do{ putStr s; display x}
+      display (SLine i x)   = do{ putStr ('\n':indentation i); display x}
+
+-----------------------------------------------------------
+-- default pretty printers: show, putDoc and hPutDoc
+-----------------------------------------------------------
+instance Show Doc where
+  showsPrec d doc       = displayS (renderPretty 0.4 80 doc)
+
+putDoc :: Doc -> IO ()
+putDoc doc              = hPutDoc stdout doc
+
+putDocM :: Monad m => (String -> m ()) -> Doc -> m ()
+putDocM putStr d = displayM putStr (renderPretty 0.4 80 d)
+
+putDocMLn :: Monad m => (String -> m ()) -> Doc -> m ()
+putDocMLn putStr d = displayM putStr (renderPretty 0.4 80 d) >> putStr "\n"
+
+hPutDoc :: Handle -> Doc -> IO ()
+hPutDoc handle doc      = displayIO handle (renderPretty 0.4 80 doc)
+
+
+
+-----------------------------------------------------------
+-- insert spaces
+-- "indentation" used to insert tabs but tabs seem to cause
+-- more trouble than they solve :-)
+-----------------------------------------------------------
+spaces n        | n <= 0    = ""
+                | otherwise = replicate n ' '
+
+indentation n   = spaces n
+
+--indentation n   | n >= 8    = '\t' : indentation (n-8)
+--                | otherwise = spaces n