module Codec.Sexpr.Parser (readSexpr,
readSexprString,
sexpr,
canonicalSexpr) where
import Codec.Sexpr
import Data.Char
import Text.ParserCombinators.ReadP
import qualified Codec.Binary.Base64.String as B64
instance Read s => Read (Sexpr s) where
readsPrec n s = map (\(a,b) -> (fmap read a, b)) s'
where
s' = readP_to_S sexpr s :: [(Sexpr String,String)]
readSexprString :: String -> Sexpr String
readSexprString s = fst . head $ readP_to_S sexpr s
readSexpr :: Read a => String -> Sexpr a
readSexpr = fmap read . readSexprString
sexpr :: ReadP (Sexpr String)
sexpr = do
skipSpaces
s <- canonicalSexpr
skipSpaces
return s
canonicalSexpr :: ReadP (Sexpr String)
canonicalSexpr = do
s <- atomR <++ listR <++ basicTransport
optional $ char '\NUL'
return s
basicTransport :: ReadP (Sexpr String)
basicTransport = do
b64Octets <- between (char '{') (char '}') $ many1 b64char
let parses = readP_to_S sexpr $ B64.decode b64Octets
choice $ map (return.fst) $ filter ((=="") . snd) parses
b64char = satisfy (\x -> isAlphaNum x || x `elem` "+/=")
b64char' = skipSpaces >> b64char
hexchar = satisfy isHexDigit
hexchar' = skipSpaces >> hexchar
listR :: ReadP (Sexpr String)
listR = do
l <- between (char '(') (char ')') $ many sexpr
return $ list l
atomR :: ReadP (Sexpr String)
atomR = unhinted +++ hinted
where
unhinted = simpleString >>= (return . atom)
hinted = do
hint <- between (char '[' >> skipSpaces)
(skipSpaces >> char ']')
simpleString
value <- simpleString
return $ hintedAtom hint value
simpleString :: ReadP String
simpleString = raw +++ token +++ b64Atom +++ hexAtom +++ quotedString
quotedString = withLength +++ withoutLength
where
withLength = do
l <- decimal
c <- between (char '"') (char '"') (many get)
let s = read ('"':c ++ "\"")
if (l == length s)
then return s
else fail "length error"
withoutLength = do
c <- between (char '"') (char '"') (many get)
return $ read ('"':c ++ "\"")
hexAtom = do
s <- withLength +++ withoutLength
return $ hexDecode s
where
withLength = do
l <- decimal
between (char '#') (char '#') (count (2*l) hexchar')
withoutLength = between (char '#') (char '#') (many1 hexchar')
hexDecode [] = ""
hexDecode (h:o:cs) = chr (16*digitToInt h + digitToInt o) : (hexDecode cs)
b64Atom = do
s <- withLength +++ withoutLength
return $ B64.decode s
where
withLength = do
l <- decimal
between (char '|') (char '|') (count (b64length l) b64char')
withoutLength =
between (char '|') (char '|') (many1 b64char')
b64length l = 4 * (ceiling (fromIntegral l / 3))
token = do
c <- satisfy isInitialTokenChar
cs <- munch isTokenChar
return (c:cs)
raw :: ReadP String
raw = do
length <- decimal
char ':'
count length get
decimal :: ReadP Int
decimal = do
s <- munch1 isNumber
return $ read s