module Text.JSON.Yocto (Value (..)) where
import Control.Applicative hiding ((<|>), many)
import Data.Char (isControl)
import Data.List (intercalate)
import Data.Map (fromList, Map, toList)
import Data.Ratio ((%), denominator, numerator)
import Prelude hiding (exp, exponent, null)
import Numeric (fromRat, readDec, readHex, showHex)
import Text.Parsec hiding (string, token)
import qualified Text.Parsec as Parsec
data Value = Null
| Boolean Bool
| Number Rational
| String String
| Array [Value]
| Object (Map String Value)
deriving (Eq, Ord)
instance Show Value where
show Null = "null"
show (Boolean b) = if b then "true" else "false"
show (Number n) = if rem == 0 then show i else show $ fromRat n
where (i, rem) = (numerator n) `divMod` (denominator n)
show (String s) = "\"" ++ concat (escape <$> s) ++ "\""
show (Array a) = "[" ++ intercalate "," (show <$> a) ++ "]"
show (Object o) = "{" ++ intercalate "," (f <$> toList o) ++ "}"
where f (n, v) = show n ++ ":" ++ show v
escape c = maybe control (\e -> '\\' : [e]) (c `lookup` exceptions) where
control = if isControl c then (encode . showHex . fromEnum) c else [c]
encode hex = "\\u" ++ replicate (4 length s) '0' ++ s where s = hex ""
exceptions = [('\b', 'b'), ('\f', 'f'), ('\n', 'n'), ('\r', 'r'),
('\t', 't'), ('\\', '\\'), ('"', '"')]
instance Read Value where
readsPrec _ string = attempt $ parse input "JSON" string
where attempt (Left failure) = error $ "invalid " ++ show failure
attempt (Right success) = [success]
input = (whitespace >> value) & getInput where
value = null <|> boolean <|> number <|> string <|> array <|> object
null = Null <$ keyword "null"
boolean = Boolean <$> (True <$ keyword "true" <|> False <$ keyword "false")
number = Number <$> rational <$> lexical (integer & fraction & exponent)
string = String <$> many character `within` (char, '"', '"')
array = Array <$> commaSep value `within` (token, '[', ']')
object = Object <$> fromList <$> commaSep pair `within` (token, '{', '}')
pair = name & (token ':' >> value) where name = (\(String s) -> s) <$> string
character = satisfy (not . \c -> isControl c || elem c "\"\\") <|> escape
where escape = char '\\' >> (oneOf "\"\\/bfnrt" <|> unicode)
unicode = char 'u' >> ordinal <$> count 4 hexDigit
integer = fromInteger <$> (0 <$ char '0' <|> natural) `maybeSignedWith` minus
fraction = option 0 (char '.' >> fmap fractional (many1 digit))
exponent = option 0 (oneOf "eE" >> natural `maybeSignedWith` (plus <|> minus))
a & b = (,) <$> a <*> b
token = lexical . Parsec.char
keyword = lexical . Parsec.string
commaSep = (`sepBy` token ',')
whitespace = many (oneOf " \t\r\n")
items `within` (term, start, end) = term start *> items <* term end
number `maybeSignedWith` sign = ($ 0) <$> option (+) sign <*> number
(plus, minus) = ((+) <$ char '+', () <$ char '-')
lexical = (<* whitespace)
integral = fst . head . readDec
ordinal = toEnum . fst . head . readHex
natural = integral <$> many1 digit
fractional digits = integral digits % (10 ^ length digits)
rational ((int, frac), exp) = (int + (signum int * frac)) * 10 ^^ exp