Prettify.hs

module Prettify
    (
    -- * Constructors
      Doc
    -- * Basic combinators
    , (<>)
    , empty
    , char
    , text
    , line
    -- * Derived combinators
    , double
    , fsep
    , hcat
    , punctuate
    -- * Renderers
    , compact
    , pretty
    , fill
    , nest
    , renderDoc
    ) where

{--
import Data.Monoid (Monoid(..))

instance Monoid Doc where
    mempty = empty
    mappend = (<>)
--}

import Data.List.Split (splitOn)

{-- snippet Doc --}
data Doc = Empty
    | Char Char
         | Text String
         | Line
         | Concat Doc Doc
         | Union Doc Doc
           deriving (Show,Eq)
{-- /snippet Doc --}

{-- snippet append --}
(<>) :: Doc -> Doc -> Doc
Empty <> y = y
x <> Empty = x
x <> y = x `Concat` y
{-- /snippet append --}

{-- snippet basic --}
empty :: Doc
empty = Empty

char :: Char -> Doc
char c = Char c

text :: String -> Doc
text "" = Empty
text s  = Text s

double :: Double -> Doc
double d = text (show d)
{-- /snippet basic --}

{-- snippet line --}
line :: Doc
line = Line
{-- /snippet line --}

{-- snippet hcat --}
hcat :: [Doc] -> Doc
hcat = fold (<>)

fold :: (Doc -> Doc -> Doc) -> [Doc] -> Doc
fold f = foldr f empty
{-- /snippet hcat --}

{-- snippet fsep --}
fsep :: [Doc] -> Doc
fsep = fold (</>)

(</>) :: Doc -> Doc -> Doc
x </> y = x <> softline <> y

softline :: Doc
softline = group line
{-- /snippet fsep --}

{-- snippet group --}
group :: Doc -> Doc
group x = flatten x `Union` x
{-- /snippet group --}

{-- snippet flatten --}
flatten :: Doc -> Doc
flatten (x `Concat` y) = flatten x `Concat` flatten y
flatten Line           = Char ' '
flatten (x `Union` _)  = flatten x
flatten other          = other
{-- /snippet flatten --}

{-- snippet punctuate --}
punctuate :: Doc -> [Doc] -> [Doc]
punctuate p []     = []
punctuate p [d]    = [d]
punctuate p (d:ds) = (d <> p) : punctuate p ds
{-- /snippet punctuate --}

renderDoc :: [Doc] -> String
renderDoc [] = ""
renderDoc (d:ds) =
    case d of
        Empty        -> renderDoc ds
        Char c       -> c : renderDoc ds
        Text s       -> s ++ renderDoc ds
        Line         -> '\n' : renderDoc ds
        a `Concat` b -> renderDoc (a:b:ds)

{-- snippet compact --}
compact :: Doc -> String
compact x = renderDoc(transform [x])
    where transform [] = []
          transform (d:ds) =
              case d of
                a `Concat` b -> transform (a:b:ds)
                _ `Union`  b -> transform (b:ds)
                _            -> d:transform (ds)
{-- /snippet compact --}

{-- snippet pretty.type --}
pretty :: Int -> Doc -> String
{-- /snippet pretty.type --}

{-- snippet pretty --}
pretty width x = renderDoc(best width 0 [x])
{-- /snippet pretty --}

best::Int->Int->[Doc]->[Doc]
best width col (d:ds) =
    case d of
              a `Concat` b -> best width col (a:b:ds)
              a `Union` b  -> nicest col (best width col (a:ds)) (best width col (b:ds))
              _            -> d:best width (col + lengthDoc d) ds
      where  nicest col a b | (width - least) `fits` a = a
                         | otherwise                = b
             least = min width col
best _ _ _        = []

lengthDoc::Doc->Int
lengthDoc Empty = 0
lengthDoc (Char _) = 1
lengthDoc (Text s) = length s
lengthDoc (Line) = 0
lengthDoc (a `Concat` b) = lengthDoc a + lengthDoc b

lineLength::[Doc]->Int
lineLength = sum.(map lengthDoc)


{-- snippet fits --}
fits :: Int -> [Doc] -> Bool
w `fits` _ | w < 0 = False
w `fits` []        = True
w `fits` (Line:_)  = True
w `fits` (c:cs)    = (w - lengthDoc c) `fits` cs
{-- /snippet fits --}

{-- snippet nest --}
nest :: Int -> Doc -> Doc
{-- /snippet nest --}
nest n x = hcat(indent 0 (transform 0 [x]))
    where transform::Int->[Doc]->[Doc]
          transform col (d:ds) =
             case d of
               a `Concat` b          -> transform col (a:b:ds)
               Union (Char ' ') Line -> transform (col + lengthDoc d) ds
               _                     -> d:transform (col + lengthDoc d) ds
          transform _ _        = []
          indent _   []        = []
          indent ind (d:ds)
                | d `elem` [Char '[', Char '{'] = Line : text (replicate ind ' ') : d : Line : text (replicate (ind+n) ' ') : indent (ind + n) ds
                | d `elem` [Char ']', Char '}'] = Line : text (replicate (ind -n) ' ') : d : Line : indent (ind - n) ds
                | d == Char ','                 = Char ',' : Line : text (replicate ind ' ') : indent ind ds
                | otherwise                     = d : indent ind ds


{-- snippet fill --}
fill :: Int -> Doc -> [Doc]
{-- /snippet fill --}
fill width x = linesAddSpace(splitOn([Line]) (best width 0 [x]))
    where linesAddSpace::[[Doc]]->[Doc]
          linesAddSpace [] = []
          linesAddSpace (l:[]) = l ++ [(text (spacesToAdd (lineLength l)))]
          linesAddSpace (l:ls) = l ++ [(text (spacesToAdd (lineLength l))), Line] ++ linesAddSpace ls
          spacesToAdd llength
                             | llength < width = replicate (width - llength) ' '
                             | otherwise       = ""


--instance Show Doc where
--    show doc = pretty 80 doc