module Text.Show.Pretty
( Name, Value(..)
, parseValue, reify, ppValue, ppDoc, ppShow
, PrettyVal(..), dumpDoc, dumpStr
, HtmlOpts(..), defaultHtmlOpts, dumpHtml, htmlPage, toHtml
) where
import Text.PrettyPrint
import qualified Text.Show.Parser as P
import Text.Show.Value
import Text.Show.PrettyVal
import Text.Show.Html
import Language.Haskell.Lexer(rmSpace,lexerPass0)
reify :: Show a => a -> Maybe Value
reify = parseValue . show
parseValue :: String -> Maybe Value
parseValue = P.parseValue . rmSpace . lexerPass0
ppShow :: Show a => a -> String
ppShow = show . ppDoc
ppDoc :: Show a => a -> Doc
ppDoc a = case parseValue txt of
Just v -> ppValue v
Nothing -> text txt
where txt = show a
dumpDoc :: PrettyVal a => a -> Doc
dumpDoc = ppValue . prettyVal
dumpStr :: PrettyVal a => a -> String
dumpStr = show . dumpDoc
ppValue :: Value -> Doc
ppValue val = case val of
Con c vs -> ppCon c vs
Rec c fs -> hang (text c) 2 $ block '{' '}' (map ppField fs)
where ppField (x,v) = text x <+> char '=' <+> ppValue v
List vs -> block '[' ']' (map ppValue vs)
Tuple vs -> block '(' ')' (map ppValue vs)
Neg v -> char '-' <> ppAtom v
Ratio x y -> ppCon "(%)" [x,y]
Integer x -> text x
Float x -> text x
Char x -> text x
String x -> text x
ppAtom :: Value -> Doc
ppAtom v
| isAtom v = ppValue v
| otherwise = parens (ppValue v)
ppCon :: Name -> [Value] -> Doc
ppCon c [] = text c
ppCon c (v : vs) = hang line1 2 (foldl addParam doc1 vs)
where (line1,doc1)
| isAtom v = (text c, ppValue v)
| otherwise = (text c <+> char '(', ppValue v <+> char ')')
addParam d p
| isAtom p = d $$ ppValue p
| otherwise = (d <+> char '(') $$ (ppValue p <+> char ')')
isAtom :: Value -> Bool
isAtom (Con _ (_:_)) = False
isAtom (Ratio {}) = False
isAtom (Neg {}) = False
isAtom _ = True
block :: Char -> Char -> [Doc] -> Doc
block a b [] = char a <> char b
block a b (d:ds) = char a <+> d
$$ vcat [ char ',' <+> x | x <- ds ]
$$ char b