module Codec.Sexpr.Printer (canonical, canonicalString,
basic, basicString,
advanced, advancedString
) where
import Codec.Sexpr
import Data.Char
import Data.Maybe
import Text.PrettyPrint
import qualified Codec.Binary.Base64.String as B64
instance Show Sexpr where
show s = advancedString s
raw s = shows (length s) . showString ":" . showString s
canonicalString s = canonical s ""
canonical :: Sexpr -> ShowS
canonical s | isAtom s && hint s == Just defaultHint = raw $ unAtom s
canonical s | isAtom s = showString "["
. raw (fromJust $ hint s)
. showString "]"
. raw (unAtom s)
canonical s | isList s = showString "("
. showString (foldr (.) id (map canonical $ unList s) $ "")
. showString ")"
basicString s = render $ basic s
basic :: Sexpr -> Doc
basic s = braces . hcat $ map char . B64.encode $ canonical s ""
advancedString s = render $ advanced s
format s | canToken s = text s
| canQuote s = quote s
| canHex s = hex s
| otherwise = base64 s
canToken (x:xs) = isInitialTokenChar x && all isTokenChar xs
canQuote s = all isQuoteableChar s
|| fromIntegral (length (show s)) <= 1.1 * fromIntegral (length s)
canHex s = length s `elem` [1,2,3,4,8,16,20]
hex s = text (show $ length s) <> (char '#') <> hcat (map (text . hexEncode) s) <> (char '#')
hexEncode x = (intToDigit h) : (intToDigit o) : []
where
(h,o) = quotRem (ord x) 16
quote s = text $ show s
base64 s = (char '|') <> hcat (map char $ B64.encode s) <> (char '|')
advanced s | isAtom s && hint s == Just defaultHint = format $ unAtom s
advanced s | isAtom s = brackets (format $ fromJust $ hint s)
<> (format $ unAtom s)
advanced s | isList s = parens $ sep (map advanced $ unList s)