module Text.HJson (Json(..), Jsonable(..), fromString, toString, escapeJString) where
import Data.Char
import Data.List
import qualified Data.Map as Map
import Data.Maybe
import Data.Ratio
import Safe
import Text.ParserCombinators.Parsec
data Json = JString String
| JNumber Rational
| JObject (Map.Map String Json)
| JBool Bool
| JNull
| JArray [Json] deriving (Eq, Show)
toString :: Json -> String
toString (JNumber r) | denominator r == 1 = show (numerator r)
| otherwise = show (fromRational r :: Double)
toString (JString s) = "\"" ++ escapeJString s ++ "\""
toString (JObject l) = "{" ++ (intercalate ", " $ map (\(k, v) -> toString (JString k) ++ ": " ++ toString v) (Map.toList l)) ++ "}"
toString (JBool True) = "true"
toString (JBool False) = "false"
toString JNull = "null"
toString (JArray vs) = "[" ++ (intercalate ", " $ map (toString) vs) ++ "]"
fromString :: String -> Either String Json
fromString s = either (Left . show) (Right) $ parse valueP "user input" s
escapeJString :: String -> String
escapeJString = concat . map (escapeJChar)
class Jsonable a where
toJson :: a -> Json
fromJson :: Json -> Maybe a
fromJson = const Nothing
instance Jsonable Json where
toJson = id
fromJson _ = Nothing
instance Jsonable Bool where
toJson b = JBool b
fromJson (JBool b) = Just b
fromJson _ = Nothing
instance Jsonable Integer where
toJson = jsonifyIntegral
fromJson (JNumber i) = Just $ round i
fromJson _ = Nothing
instance Jsonable Int where
toJson = jsonifyIntegral
fromJson (JNumber i) = Just $ round i
fromJson _ = Nothing
instance Jsonable Double where
toJson = jsonifyRealFrac
fromJson (JNumber i) = Just $ fromRational i
fromJson _ = Nothing
instance Jsonable Float where
toJson = jsonifyRealFrac
fromJson (JNumber i) = Just $ fromRational i
fromJson _ = Nothing
instance Jsonable String where
toJson = JString
fromJson (JString s) = Just s
fromJson _ = Nothing
instance (Jsonable a) => Jsonable (Map.Map String a) where
toJson = JObject . Map.mapWithKey (\_ v -> (toJson v))
fromJson (JObject m) = Just $ Map.fromList $ catMaybes $ map (\(k, v) -> maybe (Nothing) (\jv -> Just (k, jv)) (fromJson v)) $ Map.toList m
fromJson _ = Nothing
jsonifyRealFrac i = JNumber (approxRational i 1e-666)
jsonifyIntegral i = JNumber (fromIntegral i % 1)
escapeJChar '\n' = "\\n"
escapeJChar '\b' = "\\b"
escapeJChar '\f' = "\\f"
escapeJChar '\t' = "\\t"
escapeJChar '\r' = "\\r"
escapeJChar '\\' = "\\\\"
escapeJChar '"' = "\\\""
escapeJChar c = [c]
valueP = do
spaces
jsonV <- stringP <|> numberP <|> objectP <|> arrayP <|> boolP <|> nullP
spaces
return jsonV
objectP = do
char '{'
spaces
values <- keyValueP `sepBy` commaP
spaces
char '}'
return $ JObject (Map.fromList values)
commaP = do
spaces
char ','
spaces
keyValueP = do
spaces
JString keyStringV <- stringP
spaces
char ':'
spaces
valueV <- valueP
spaces
return (keyStringV, valueV)
arrayP = do
char '['
spaces
values <- valueP `sepBy` commaP
spaces
char ']'
return $ JArray values
stringP = do
char '"'
str <- manyTill stringElementP (char '"')
return $ JString str
stringElementP = do
escapeSeqP <|> anyChar
escapeSeqP = do
char '\\'
(char '"') <|>
(char '\\') <|>
(char '/') <|>
('\b' <$ char 'b') <|>
('\f' <$ char 'f') <|>
('\n' <$ char 'n') <|>
('\r' <$ char 'r') <|>
('\t' <$ char 't') <|>
unicodeP
unicodeP = do
digitsV <- count 4 hexDigit
let numberV = read ("0x" ++ digitsV)
return $ chr numberV
numberP = do
minusV <- optionMaybe (char '-')
digitsV <- many1 digit
maybeFractionalV <- optionMaybe (char '.' >> many digit)
exponentV <- optionMaybe (do
oneOf "eE"
signV <- optionMaybe (char '+' <|> char '-')
eDigitsV <- many1 digit
let readDigits = read eDigitsV :: Integer
return $ case signV of
Just '-' -> ('-', readDigits)
otherwise -> ('+', readDigits))
let fractionalV = fromMaybe "" maybeFractionalV
let upV = read (digitsV ++ fractionalV) :: Integer
let downV = 10 ^ genericLength fractionalV
return $ case exponentV of
Nothing -> JNumber (upV % downV)
Just ('-', powr) -> JNumber (upV % (downV * 10 ^ powr))
Just (_, powr) -> JNumber ((upV * 10 ^ powr) % downV)
boolP = (JBool True <$ string "true") <|> (JBool False <$ string "false")
nullP = JNull <$ string "null"
x <$ m = m >> return x