module Text.HJson (
Json(..)
, fromString
, toString
, escapeJString
, jsonParser
, Jsonable(..)
, List(..)
, Object(..)
, LaxObject(..)
) where
import Control.Applicative
import Control.Monad
import Data.Char
import Data.List
import qualified Data.Foldable as F
import qualified Data.Traversable as T
import qualified Data.Map as Map
import qualified Data.IntMap as IntMap
import qualified Data.Set as Set
import qualified Data.IntSet as IntSet
import qualified Data.Sequence as Seq
import Data.Maybe
import Data.Ratio
import Data.Typeable
import Data.Data
import Text.Parsec hiding (many, (<|>))
import Text.Parsec.Prim (ParsecT)
data Json = JString String
| JNumber Rational
| JObject (Map.Map String Json)
| JBool Bool
| JNull
| JArray [Json]
deriving (Eq, Show, Data, Typeable)
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 ParseError Json
fromString s = parse valueP "user input" s
escapeJString :: String -> String
escapeJString = concatMap escapeJChar
class Jsonable a where
toJson :: a -> Json
fromJson :: Json -> Maybe a
fromJson = const Nothing
newtype List a = List { asList :: [a] } deriving (Show, Eq, Ord)
newtype Object a = Object { asMap :: Map.Map String a } deriving (Show, Eq)
newtype LaxObject a = LaxObject { asLaxMap :: Map.Map String a } deriving (Show, Eq)
instance Jsonable Json where
toJson = id
fromJson = Just
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 (Maybe a) where
toJson (Just a) = JObject $ Map.singleton "just" (toJson a)
toJson Nothing = JNull
fromJson (JNull) = Just Nothing
fromJson (JObject m) = do
guard $ Map.size m == 1
Just <$> (fromJson =<< Map.lookup "just" m)
fromJson _ = Nothing
instance (Jsonable a, Jsonable b) => Jsonable (Either a b) where
toJson (Left a) = JObject $ Map.singleton "left" (toJson a)
toJson (Right a) = JObject $ Map.singleton "right" (toJson a)
fromJson (JObject m) = case Map.toList m of
[("left", j)] -> Left <$> fromJson j
[("right", j)] -> Right <$> fromJson j
_ -> Nothing
fromJson _ = Nothing
instance (Jsonable a, Jsonable b) => Jsonable (a,b) where
toJson (a,b) = JArray [toJson a, toJson b]
fromJson (JArray [a,b]) = (,) <$> fromJson a <*> fromJson b
fromJson _ = Nothing
instance (Jsonable a, Jsonable b, Jsonable c) => Jsonable (a,b,c) where
toJson (a,b,c) = JArray [toJson a, toJson b, toJson c]
fromJson (JArray [a,b,c]) = (,,) <$> fromJson a <*> fromJson b <*> fromJson c
fromJson _ = Nothing
instance (Jsonable a, Jsonable b, Jsonable c, Jsonable d) => Jsonable (a,b,c,d) where
toJson (a,b,c,d) = JArray [toJson a, toJson b, toJson c, toJson d]
fromJson (JArray [a,b,c,d]) = (,,,) <$> fromJson a <*> fromJson b <*> fromJson c <*> fromJson d
fromJson _ = Nothing
instance (Jsonable a, Jsonable b, Jsonable c, Jsonable d, Jsonable e) => Jsonable (a,b,c,d,e) where
toJson (a,b,c,d,e) = JArray [toJson a, toJson b, toJson c, toJson d, toJson e]
fromJson (JArray [a,b,c,d,e]) = (,,,,) <$> fromJson a <*> fromJson b <*> fromJson c <*> fromJson d <*> fromJson e
fromJson _ = Nothing
instance (Jsonable a, Ord a, Jsonable b) => Jsonable (Map.Map a b) where
toJson = JArray . map toJson . Map.toList
fromJson j = Map.fromList . asList <$> fromJson j
instance Jsonable a => Jsonable (IntMap.IntMap a) where
toJson = JArray . map toJson . IntMap.toList
fromJson j = IntMap.fromList . asList <$> fromJson j
instance (Jsonable a, Ord a) => Jsonable (Set.Set a) where
toJson = JArray . map toJson . Set.toList
fromJson j = Set.fromList . asList <$> fromJson j
instance Jsonable IntSet.IntSet where
toJson = JArray . map toJson . IntSet.toList
fromJson j = IntSet.fromList . asList <$> fromJson j
instance Jsonable a => Jsonable (Seq.Seq a) where
toJson = JArray . map toJson . F.toList
fromJson j = Seq.fromList . asList <$> fromJson j
instance Jsonable a => Jsonable (List a) where
toJson = JArray . map toJson . asList
fromJson (JArray xs) = List <$> mapM fromJson xs
fromJson _ = Nothing
instance (Jsonable a) => Jsonable (Object a) where
toJson (Object m) = JObject $ fmap toJson m
fromJson (JObject m) = Object <$> T.mapM fromJson m
fromJson _ = Nothing
instance (Jsonable a) => Jsonable (LaxObject a) where
toJson (LaxObject m) = JObject $ fmap toJson m
fromJson (JObject m) = Just $ LaxObject $ Map.mapMaybe fromJson m
fromJson _ = Nothing
jsonifyRealFrac :: RealFrac a => a -> Json
jsonifyRealFrac i = JNumber (approxRational i 1e-666)
jsonifyIntegral :: Integral a => a -> Json
jsonifyIntegral i = JNumber (fromIntegral i % 1)
escapeJChar :: Char -> [Char]
escapeJChar '\n' = "\\n"
escapeJChar '\b' = "\\b"
escapeJChar '\f' = "\\f"
escapeJChar '\t' = "\\t"
escapeJChar '\r' = "\\r"
escapeJChar '\\' = "\\\\"
escapeJChar '"' = "\\\""
escapeJChar c = [c]
jsonParser :: Monad m => ParsecT String s m Json
jsonParser = valueP
valueP :: Monad m => ParsecT String s m Json
valueP = spaces *> (stringP <|> numberP <|> objectP <|> arrayP <|> boolP <|> nullP) <* spaces
objectP :: Monad m => ParsecT String s m Json
objectP =
char '{' *> spaces *>
(JObject . Map.fromList <$> (keyValueP `sepBy` commaP))
<* spaces <* char '}'
commaP :: Monad m => ParsecT String s m ()
commaP = () <$ spaces >> char ',' >> spaces
keyValueP :: Monad m => ParsecT String s m (String,Json)
keyValueP = do
spaces
JString keyStringV <- stringP
spaces
char ':'
spaces
valueV <- valueP
spaces
return (keyStringV, valueV)
arrayP :: Monad m => ParsecT String s m Json
arrayP =
char '[' *> spaces *>
(JArray <$> (valueP `sepBy` commaP))
<* spaces <* char ']'
stringP :: Monad m => ParsecT String s m Json
stringP = char '"' *> (JString <$> manyTill stringElementP (char '"'))
stringElementP :: Monad m => ParsecT String s m Char
stringElementP = escapeSeqP <|> anyChar
escapeSeqP :: Monad m => ParsecT String s m Char
escapeSeqP = do
char '\\'
(char '"') <|>
(char '\\') <|>
(char '/') <|>
('\b' <$ char 'b') <|>
('\f' <$ char 'f') <|>
('\n' <$ char 'n') <|>
('\r' <$ char 'r') <|>
('\t' <$ char 't') <|>
unicodeP
unicodeP :: Monad m => ParsecT String s m Char
unicodeP = do
char 'u'
digitsV <- count 4 hexDigit
let numberV = read ("0x" ++ digitsV)
if numberV >= 0xD800 && numberV <= 0xDFFF then do
guard (numberV <= 0xDBFF) <?> "valid UTF-16 char or first half"
let numberVHigh = numberV 0xD800
digitsVLow <- do
char '\\'
char 'u'
count 4 hexDigit
<?> "continuation of the UTF-16 surrogate pair"
let numberVLow = read ("0x" ++ digitsVLow) 0xDC00
guard (numberVLow >= 0 && numberVLow <= 0x3FF) <?> "valid UTF-16 second half"
return $ chr (0x10000 + numberVHigh * 2^10 + numberVLow)
else
return $ chr numberV
numberP :: Monad m => ParsecT String s m Json
numberP = do
sign <- (1 <$ char '-') <|> return 1
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 = sign * 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 :: Monad m => ParsecT String s m Json
boolP = (JBool True <$ string "true") <|> (JBool False <$ string "false")
nullP :: Monad m => ParsecT String u m Json
nullP = JNull <$ string "null"