content: {-# LANGUAGE NoMonomorphismRestriction #-}
  -----------------------------------------------------------
  -- 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 System.IO      (Handle,hPutStr,hPutChar,stdout)
  import Doc.DocLike hiding(empty)
  import qualified Doc.DocLike as DocLike
  import Data.Monoid(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
  