module Wumpus.Core.Utils.FormatCombinators
(
Doc
, DocS
, Format(..)
, empty
, showsDoc
, (<>)
, (<+>)
, vconcat
, separate
, hcat
, hsep
, vcat
, text
, char
, int
, integer
, integral
, float
, double
, space
, comma
, semicolon
, line
, fill
, punctuate
, enclose
, squotes
, dquotes
, parens
, brackets
, braces
, angles
, lparen
, rparen
, lbracket
, rbracket
, lbrace
, rbrace
, langle
, rangle
, list
, tupled
, semiBraces
, indent
) where
import Data.Monoid
import Numeric
data Doc = Doc1 ShowS
| Join Doc Doc
| Line
| Indent !Int Doc
type DocS = Doc -> Doc
unDoc :: Doc -> ShowS
unDoc = step 0 id
where
step _ acc (Doc1 sf) = acc . sf
step n acc (Join a b) = let acc' = step n acc a in step n acc' b
step n acc Line = acc . showChar '\n' . indentS n
step n acc (Indent i d) = step (n+i) (acc . (indentS i)) d
indentS :: Int -> ShowS
indentS i | i < 1 = id
| otherwise = showString $ replicate i ' '
runDoc :: Doc -> String
runDoc = ($ "") . unDoc
instance Show Doc where
show = runDoc
instance Eq Doc where
(==) (Doc1 f) (Doc1 g) = (f []) == (g [])
(==) (Join a b) (Join x y) = a == x && b == y
(==) Line Line = True
(==) (Indent i a) (Indent j x) = i == j && a == x
(==) _ _ = False
instance Monoid Doc where
mempty = empty
mappend = (<>)
class Format a where format :: a -> Doc
instance Format Int where
format = int
instance Format Integer where
format = integer
instance Format Double where
format = double
infixr 6 <>, <+>
empty :: Doc
empty = Doc1 id
showsDoc :: ShowS -> Doc
showsDoc = Doc1
(<>) :: Doc -> Doc -> Doc
a <> b = Join a b
(<+>) :: Doc -> Doc -> Doc
a <+> b = Join a (Join space b)
vconcat :: Doc -> Doc -> Doc
vconcat a b = a <> Line <> b
separate :: Doc -> [Doc] -> Doc
separate _ [] = empty
separate sep (a:as) = step a as
where
step acc [] = acc
step acc (x:xs) = step (acc <> sep <> x) xs
hcat :: [Doc] -> Doc
hcat = foldr (<>) empty
hsep :: [Doc] -> Doc
hsep = separate space
vcat :: [Doc] -> Doc
vcat [] = empty
vcat (x:xs) = step x xs
where
step acc (z:zs) = step (acc `vconcat` z) zs
step acc [] = acc
text :: String -> Doc
text = Doc1 . showString
char :: Char -> Doc
char = Doc1 . showChar
int :: Int -> Doc
int = Doc1 . showInt
integer :: Integer -> Doc
integer = Doc1 . showInt
integral :: Integral a => a -> Doc
integral = Doc1 . showInt
float :: Double -> Doc
float = Doc1 . showFloat
double :: Double -> Doc
double = Doc1 . showFloat
space :: Doc
space = char ' '
comma :: Doc
comma = char ','
semicolon :: Doc
semicolon = char ';'
line :: Doc
line = char '\n'
fill :: Int -> Doc -> Doc
fill i d = Doc1 (padr i ' ' $ unDoc d)
padr :: Int -> Char -> ShowS -> ShowS
padr i c df = step (length $ df [])
where
step len | len >= i = df
| otherwise = df . showString (replicate (ilen) c)
punctuate :: Doc -> [Doc] -> Doc
punctuate _ [] = empty
punctuate _ [x] = x
punctuate s (x:xs) = x <> s <> punctuate s xs
enclose :: Doc -> Doc -> Doc -> Doc
enclose l r d = l <> d <> r
squotes :: Doc -> Doc
squotes = enclose (char '\'') (char '\'')
dquotes :: Doc -> Doc
dquotes = enclose (char '"') (char '"')
parens :: Doc -> Doc
parens = enclose lparen rparen
brackets :: Doc -> Doc
brackets = enclose lbracket rbracket
braces :: Doc -> Doc
braces = enclose lbrace rbrace
angles :: Doc -> Doc
angles = enclose langle rangle
lparen :: Doc
lparen = char '('
rparen :: Doc
rparen = char ')'
lbracket :: Doc
lbracket = char '['
rbracket :: Doc
rbracket = char ']'
lbrace :: Doc
lbrace = char '{'
rbrace :: Doc
rbrace = char '}'
langle :: Doc
langle = char '<'
rangle :: Doc
rangle = char '>'
list :: [Doc] -> Doc
list = brackets . punctuate comma
tupled :: [Doc] -> Doc
tupled = parens . punctuate comma
semiBraces :: [Doc] -> Doc
semiBraces = braces . punctuate semicolon
indent :: Int -> Doc -> Doc
indent i d | i < 1 = d
| otherwise = Indent i d