module Codec.Sexpr.Printer (
canonicalString,
basicString,
advancedString,
canonical,
basic,
advanced,
putCanonical, putCanonicalBS
) where
import Codec.Sexpr
import Data.Binary.Put
import qualified Data.ByteString.Char8 as B
import Data.Char
import Data.Maybe
import Text.PrettyPrint
import qualified Codec.Binary.Base64.String as B64
instance Show (Sexpr String) where
show s = advancedString s
instance Show s => Show (Sexpr s) where
show s = advancedString $ fmap show s
raw s = shows (length s) . showString ":" . showString s
canonicalString :: Sexpr String -> String
canonicalString s = canonical s ""
canonical :: Sexpr String -> 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 ")"
putRaw :: String -> Put
putRaw s = do
putByteString . B.pack . show $ length s
putChar' ':'
putByteString (B.pack s)
putRawBS :: B.ByteString -> Put
putRawBS s = do
putByteString . B.pack . show $ B.length s
putChar' ':'
putByteString s
putChar' = putWord8 . fromIntegral . ord
putCanonical :: Sexpr String -> Put
putCanonical = putCanonicalHelper putRaw
putCanonicalBS :: Sexpr B.ByteString -> Put
putCanonicalBS = putCanonicalHelper putRawBS
putCanonicalHelper :: (a -> Put) -> Sexpr a -> Put
putCanonicalHelper putRaw' s | isAtom s && hint s ==
Just defaultHint = putRaw' $ unAtom s
putCanonicalHelper putRaw' s | isAtom s = do
putChar' '['
putRaw (fromJust $ hint s)
putChar' ']'
putRaw' (unAtom s)
putCanonicalHelper putRaw' s | isList s = do
putChar' '('
mapM_ (putCanonicalHelper putRaw') $ unList s
putChar' ')'
basicString :: Sexpr String -> String
basicString s = render $ basic s
basic :: Sexpr String -> Doc
basic s = braces . hcat $ map char . B64.encode $ canonical s ""
advancedString :: Sexpr String -> String
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 :: Sexpr String -> Doc
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)