module Text.DeadSimpleJSON (
parse,
parse',
parseM,
Value (..),
JSON,
(?),
top,
Convert (..)
) where
import Prelude hiding (True, False)
import qualified Prelude
import Data.Char (isControl)
import qualified Data.Map as M
import qualified Data.Vector as V
import Text.Parsec hiding (parse)
import Control.Applicative ((*>), (<*))
import Data.Functor.Identity
import Numeric (showHex, readHex)
import Text.DeadSimpleJSON.Convert
import Text.DeadSimpleJSON.Query
import Text.DeadSimpleJSON.Types
instance Show JSON where
show (JSON jsonObject) = write jsonObject
instance Read JSON where
readsPrec _ =
either (const []) (:[]) . runIdentity . runParserT json () "-"
parse :: String -> Either ParseError JSON
parse str = runIdentity $ runParserT json' () "-" str
parse' :: String -> Maybe Value
parse' = parseM
parseM :: Monad m => String -> m Value
parseM = either (fail . show) (return . top) . parse
top :: JSON -> Value
top (JSON v) = v
write x = case x of
(Number n e) -> writeNumber n e
(String s) -> '"' : writeString s
(Object m) -> writeObject m
(Array v) -> writeArray v
True -> "true"
False -> "false"
Null -> "null"
writeNumber n 0 = show n
writeNumber n e = show n ++ "e" ++ show e
writeString (x:xs)
| isControl x = "\\u" ++ showHex (fromEnum x) (writeString xs)
| x == '\x2028' = "\\u2028"
| x == '\x2029' = "\\u2029"
| x == '\\' = "\\\\" ++ writeString xs
| x == '\"' = "\\\"" ++ writeString xs
| otherwise = x : writeString xs
writeString [] = "\""
writeArray arr
| V.null arr = "[]"
| otherwise = '[' : (tail $ concat $ V.foldr (\v l -> "," : write v : l) ["]"] arr)
writeObject obj
| M.null obj = "{}"
| otherwise = '{' : (tail $ concat $ M.foldrWithKey' (\k v l -> ",\"" : writeString k : ":" : write v : l) ["}"] obj)
json' :: Monad m => ParsecT String () m JSON
json :: Monad m => ParsecT String () m (JSON, String)
value, jsonString, number, negativeNumber, nonNegativeNumber, object, array
:: Monad m => ParsecT String () m Value
stringChar, escapedChar
:: Monad m => ParsecT String () m Char
keyValue
:: Monad m => ParsecT String () m (String, Value)
mkNumber
:: Monad m => String -> String -> String -> ParsecT String u m Value
json = do
val <- spaces *> (object <|> array)
rest <- many anyToken
return (JSON val, rest)
json' = do
val <- spaces >> (object <|> array) <* spaces
(char '\EOT' >> return ()) <|> eof
return $ JSON val
value = jsonString
<|> number
<|> object
<|> array
<|> (string "true" >> return True)
<|> (string "false" >> return False)
<|> (string "null" >> return Null)
jsonString = do
char '"'
str <- many (stringChar <|> escapedChar)
char '"'
return $ String str
stringChar = satisfy (\x -> not (isControl x || (elem x "\\\"")))
escapedChar = do
char '\\'
oneOf "\"\\/"
<|> (oneOf "bfnrt" >>= special)
<|> (char 'u' >> count 4 hexDigit >>= convert)
<?> "escape sequence: one of b, f, n, r, t, or uXXXX"
where
special chr = return $ case chr of
'b' -> '\b'
'f' -> '\f'
'n' -> '\n'
'r' -> '\r'
't' -> '\t'
_ -> undefined
convert str = do
let [(hex, _)] = readHex str
return $ toEnum hex
number = negativeNumber <|> nonNegativeNumber
negativeNumber = do
char '-'
(Number nom denom) <- nonNegativeNumber
return $ Number (negate nom) denom
nonNegativeNumber = do
num <- digits <|> string "0"
mantisse <- option "" (char '.' *> many1 digit)
exp <- option "0" exponent
mkNumber num mantisse exp
where
digits = do
first <- oneOf ['1'..'9']
rest <- many digit
return $ first : rest
exponent = do
oneOf "eE"
sign <- option '+' $ oneOf "+-"
exp <- many1 digit
return $ sign : exp
mkNumber str1 str2 ('+':str3) = mkNumber str1 str2 str3
mkNumber str1 str2 str3 = do
let str2' = reverse $ dropWhile (== '0') $ reverse str2
[(nom, _)] = reads (str1 ++ str2')
[(exp, _)] = reads (str3)
exp' = negate (fromIntegral (length str2') + negate exp)
num n d
| n == 0 = Number 0 0
| n `rem` 10 == 0 = num (n `quot` 10) (d+1)
| otherwise = Number n d
return $ num nom exp'
object = do
pairs <- between (char '{') (char '}') $ do
spaces
sepBy keyValue (char ',' >> spaces)
return $ Object $ M.fromList pairs
keyValue = do
(String key) <- jsonString <* char ':'
val <- between spaces spaces value
return (key, val)
array = do
values <- between (char '[') (char ']') $ do
spaces
sepBy (value <* spaces) (char ',' >> spaces)
return $ Array $ V.fromList values