module Data.JSON2
(
Json(..), Jsons,
ToJson(..), FromJson(..),
emptyObj, (==>), fromList,
unionObj, unionsObj, unionRecObj,
toString,
pprint, pprints,
singleObj
)
where
import Data.List
import qualified Data.Map as Map
import Data.Ratio
import Data.Typeable (Typeable)
import Data.Time.Clock (UTCTime)
import Data.Time.Format (formatTime, parseTime)
import System.Locale (defaultTimeLocale)
infixr 6 ==>
data Json = JString String
| JNumber Rational
| JBool !Bool
| JNull
| JArray [Json]
| JObject (Map.Map String Json) deriving (Eq, Ord, Typeable, Show, Read)
type Jsons = [Json]
class ToJson a where
toJson :: a -> Json
class FromJson a where
fromJson :: Json -> a
instance ToJson UTCTime where
toJson ut = JString $ formatTime defaultTimeLocale templateUTC ut
instance FromJson (Maybe UTCTime) where
fromJson (JString t) = parseTime defaultTimeLocale templateUTC t :: Maybe UTCTime
templateUTC = "%Y-%m-%d %T UTC"
instance ToJson () where
toJson () = JArray []
instance ToJson Char where
toJson x = JString [x]
instance ToJson Json where
toJson = id
instance FromJson Json where
fromJson = id
instance ToJson a => ToJson (Maybe a) where
toJson = maybe JNull toJson
instance FromJson a => FromJson (Maybe a) where
fromJson x = if x == JNull then Nothing else Just (fromJson x)
instance (ToJson a, ToJson b) => ToJson (Either a b) where
toJson (Left a) = toJson a
toJson (Right b) = toJson b
instance ToJson Bool where
toJson x = JBool x
instance FromJson Bool where
fromJson (JBool x) = x
instance ToJson String where
toJson x = JString x
instance FromJson String where
fromJson (JString x) = x
instance ToJson Integer where
toJson = jsonifyIntegral
instance FromJson Integer where
fromJson (JNumber i) = round i
instance ToJson Int where
toJson = jsonifyIntegral
instance FromJson Int where
fromJson (JNumber i) = round i
instance ToJson Double where
toJson = jsonifyRealFrac
instance FromJson Double where
fromJson (JNumber i) = fromRational i
instance ToJson Float where
toJson = jsonifyRealFrac
instance FromJson Float where
fromJson (JNumber i) = fromRational i
instance (ToJson a) => ToJson (Map.Map String a) where
toJson = JObject . Map.map toJson
instance (FromJson a) => FromJson (Map.Map String a) where
fromJson (JObject m) = Map.map fromJson m
instance (ToJson a) => ToJson [a] where
toJson = JArray . map toJson
instance (FromJson a) => FromJson [a] where
fromJson (JArray xs) = map fromJson xs
instance (ToJson t1, ToJson t2) => ToJson (t1, t2) where
toJson (x1, x2) = JArray [toJson x1, toJson x2]
instance (FromJson t1, FromJson t2) => FromJson (t1, t2) where
fromJson (JArray [x, y]) = (fromJson x, fromJson y)
instance (ToJson t1, ToJson t2, ToJson t3) => ToJson (t1, t2, t3) where
toJson (x1, x2, x3) = JArray [toJson x1, toJson x2, toJson x3]
instance (FromJson t1, FromJson t2, FromJson t3) => FromJson (t1, t2, t3) where
fromJson (JArray [x1, x2, x3]) = (fromJson x1, fromJson x2, fromJson x3)
instance (ToJson t1, ToJson t2, ToJson t3, ToJson t4) => ToJson (t1, t2, t3, t4) where
toJson (x1, x2, x3, x4) = JArray [toJson x1, toJson x2, toJson x3, toJson x4]
instance (FromJson t1, FromJson t2, FromJson t3, FromJson t4) => FromJson (t1, t2, t3, t4) where
fromJson (JArray [x1, x2, x3, x4]) = (fromJson x1, fromJson x2, fromJson x3, fromJson x4)
instance (ToJson t1, ToJson t2, ToJson t3, ToJson t4, ToJson t5) => ToJson (t1, t2, t3, t4, t5) where
toJson (x1, x2, x3, x4, x5) = JArray [toJson x1, toJson x2, toJson x3, toJson x4, toJson x5]
instance (FromJson t1, FromJson t2, FromJson t3, FromJson t4, FromJson t5) => FromJson (t1, t2, t3, t4, t5) where
fromJson (JArray [x1, x2, x3, x4, x5]) = (fromJson x1, fromJson x2, fromJson x3, fromJson x4, fromJson x5)
emptyObj :: Json
emptyObj = JObject (Map.empty)
singleObj :: ToJson a => String -> a -> Json
singleObj k v = JObject (Map.singleton k (toJson v))
(==>) :: ToJson a => String -> a -> Json
(==>) = singleObj
fromList :: ToJson a => [(String, a)] -> Json
fromList xs = JObject $ Map.fromList (map (\(k,v) -> (k, toJson v)) xs)
unionObj :: Json -> Json -> Json
unionObj (JObject x ) (JObject y) = JObject $ Map.union x y
unionObj x _ = x
unionsObj :: [Json] -> Json
unionsObj xs = foldl unionObj emptyObj xs
unionRecObj :: Json -> Json -> Json
unionRecObj (JObject x) (JObject y) = JObject $
Map.unionWith (\v1 v2 -> unionRecObj v1 v2) x y
unionRecObj x _ = x
toString :: Json -> String
toString (JNumber r)
| denominator r == 1 = show (numerator r)
| otherwise = show (fromRational r :: Double)
toString (JBool True) = "true"
toString (JBool False) = "false"
toString JNull = "null"
toString (JString s) = "\"" ++ escJStr s ++ "\""
toString (JArray vs) = "[" ++ (intercalate ", " $ map (toString) vs) ++ "]"
toString (JObject l) = "{" ++ (intercalate ", " $ map (\(k, v) -> toString (JString k) ++ ": " ++ toString v) (Map.toList l)) ++ "}"
pprint :: Json -> IO ()
pprint j = putStrLn $ pprint' " " 0 j
pprint' :: String -> Integer -> Json -> String
pprint' indenter levels (JArray xs) = "[" ++ (intercalate ", " $ map (pprint' indenter levels) xs) ++ "]"
pprint' indenter levels (JObject mp) = let
currentIndent = (concat (genericReplicate levels indenter))
in intercalate "\n" $ ["{", intercalate ",\n" (map (((currentIndent ++ indenter) ++) . (\(key, value) -> pprint' indenter levels (JString key) ++ ": " ++ pprint' indenter (levels + 1) value)) $ Map.toList mp), currentIndent ++ "}"]
pprint' _ _ a = toString a
pprints :: [Json] -> IO ()
pprints js = putStrLn $
"[\n " ++ ( intercalate "," $ map (\j -> (pprint' " " 1 ) j) js) ++ "\n]"
jsonifyRealFrac i = JNumber (approxRational i 1e-666)
jsonifyIntegral i = JNumber (fromIntegral i % 1)
escJStr :: String -> String
escJStr = concat . map (escJChar)
escJChar c = case c of
'\n' -> "\\n"
'\b' -> "\\b"
'\f' -> "\\f"
'\t' -> "\\t"
'\r' -> "\\r"
'\\' -> "\\\\"
'\"' -> "\\\""
_ -> [c]