    --------------------------------------------------------------------------------
    {-| Module      :  PPrint
        Copyright   :  (c) Daan Leijen 2000, <http://www.cs.uu.nl/~daan>
        Version      : $version: $

        Maintainer  :  daan@cs.uu.nl
        Stability   :  provisional
        Portability :  portable

        Pretty print library 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
    -}
    ---------------------------------------------------------------------------------
    module UU.PPrint
            ( Doc
            , Pretty, pretty

            , show, putDoc, hPutDoc

            , (<>)
            , (<+>)
            , (</>), (<//>)
            , (<$>), (<$$>)

            , sep, fillSep, hsep, vsep
            , cat, fillCat, hcat, vcat
            , punctuate

            , align, hang, indent
            , fill, fillBreak

            , list, tupled, semiBraces, encloseSep
            , angles, langle, rangle
            , parens, lparen, rparen
            , braces, lbrace, rbrace
            , brackets, lbracket, rbracket
            , dquotes, dquote, squotes, squote

            , comma, space, dot, backslash
            , semi, colon, equals

            , string, bool, int, integer, float, double, rational

            , softline, softbreak
            , empty, char, text, line, linebreak, nest, group
            , column, nesting, width

            , SimpleDoc(..)
            , renderPretty, renderCompact
            , displayS, displayIO
            ) where

    import System.IO      (Handle,hPutStr,hPutChar,stdout)

    infixr 5 </>,<//>,<$>,<$$>
    infixr 6 <>,<+>

    -----------------------------------------------------------
    -- list, tupled and semiBraces pretty print a list of
    -- documents either horizontally or vertically aligned.
    -----------------------------------------------------------
    list            = encloseSep lbracket rbracket comma
    tupled          = encloseSep lparen   rparen  comma
    semiBraces      = encloseSep lbrace   rbrace  semi

    encloseSep left right sep ds
        = case ds of
            []  -> left <> right
            [d] -> left <> d <> right
            _   -> align (cat (zipWith (<>) (left : repeat sep) ds) <> right)

    -----------------------------------------------------------
    -- punctuate p [d1,d2,...,dn] => [d1 <> p,d2 <> p, ... ,dn]
    -----------------------------------------------------------
    punctuate p []      = []
    punctuate p [d]     = [d]
    punctuate p (d:ds)  = (d <> p) : punctuate p ds

    -----------------------------------------------------------
    -- high-level combinators
    -----------------------------------------------------------
    sep             = group . vsep
    fillSep         = fold (</>)
    hsep            = fold (<+>)
    vsep            = fold (<$>)

    cat             = group . vcat
    fillCat         = fold (<//>)
    hcat            = fold (<>)
    vcat            = fold (<$$>)

    fold f []       = empty
    fold f ds       = foldr1 f ds

    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

    squotes         = enclose squote squote
    dquotes         = enclose dquote dquote
    braces          = enclose lbrace rbrace
    parens          = enclose lparen rparen
    angles          = enclose langle rangle
    brackets        = enclose lbracket rbracket
    enclose l r x   = l <> x <> r

    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 '='

    -----------------------------------------------------------
    -- 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)

    -----------------------------------------------------------
    -- overloading "pretty"
    -----------------------------------------------------------
    class Pretty a where
      pretty        :: a -> Doc
      prettyList    :: [a] -> Doc
      prettyList    = list . map pretty

    instance Pretty a => Pretty [a] where
      pretty        = prettyList

    instance Pretty Doc where
      pretty        = id

    instance Pretty () where
      pretty ()     = text "()"

    instance Pretty Bool where
      pretty b      = bool b

    instance Pretty Char where
      pretty c      = char c
      prettyList s  = string s

    instance Pretty Int where
      pretty i      = int i

    instance Pretty Integer where
      pretty i      = integer i

    instance Pretty Float where
      pretty f      = float f

    instance Pretty Double where
      pretty d      = double d

    --instance Pretty Rational where
    --  pretty r      = rational r

    instance (Pretty a,Pretty b) => Pretty (a,b) where
      pretty (x,y)  = tupled [pretty x, pretty y]

    instance (Pretty a,Pretty b,Pretty c) => Pretty (a,b,c) where
      pretty (x,y,z)= tupled [pretty x, pretty y, pretty z]

    instance Pretty a => Pretty (Maybe a) where
      pretty Nothing        = empty
      pretty (Just x)       = pretty x

    -----------------------------------------------------------
    -- 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

    empty           = Empty

    char '\n'       = line
    char c          = Char c

    text ""         = Empty
    text s          = Text (length s) 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 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}

    -----------------------------------------------------------
    -- 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

    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