json2-0.2: Data/JSON2.hs

{-# Language TypeSynonymInstances, FlexibleInstances, IncoherentInstances #-}
module Data.JSON2
  (
   -- * Data types and classes
   Json(..), Jsons,
   ToJson(..), FromJson(..),
   -- * Building JSON objects
   emptyObj, singleObj, (==>), fromList,
   -- * Union JSON objects
   unionObj, unionsObj, unionRecObj,
   -- * Rendering to string
   toString,
   -- * Pretty print
   pprint, pprints
  ) 
where

import Data.List
import qualified Data.Map as Map
import Data.Ratio

infixr 6 ==>

-- * Data types and classes

data Json = JString String
	  | JNumber Rational
	  | JBool Bool
	  | JNull
	  | JArray [Json]
	  | JObject (Map.Map String Json) deriving (Eq, Show, Read)

type Jsons = [Json]

-- | This module provides instances @ToJson@ for :
-- @(), Char,  Json, Maybe, Bool, String, Integr, Int, Double, Float,
-- Rational, Map String a, List, tuples 2-5 sizes@ .
--
-- Example :
--
-- > table :: [(Int, Maybe String, Bool)]
-- > table = [
-- >     (1, Just "One", False),
-- >     (2, Nothing,    True)
-- >   ]
-- > jTable = toJson table
-- > pprint jTable
-- > [[1, "One", false], [2, null, true]]
class ToJson a where
    toJson :: a -> Json

-- | This module provides instances @FromJson@ for :
-- @Json, Maybe, Bool, String, Integr, Int, Double, Float,
-- Rational, Map String a, List, tuples 2-5 sizes@ .
--
-- Example :
--
-- > fromJson jTable :: [(Double, Maybe String, Bool)]
-- > [(1.0, Just "One", False), (2.0, Nothing, True)]
class FromJson a where
    fromJson :: Json -> a

-- ** Instances FromJson and ToJson

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 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 Rational where
    toJson = JNumber
instance FromJson Rational where
    fromJson (JNumber i) =  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)


-- * Building JSON objects

-- | Create empty JSON object.
emptyObj :: Json
emptyObj = JObject (Map.empty)

-- | Create single JSON object.
singleObj :: ToJson a => String -> a -> Json
singleObj k v = JObject (Map.singleton k (toJson v))

-- | @(`==>`)@ Eq @`singleObj`@ .
(==>) :: ToJson a => String -> a -> Json
(==>) = singleObj

-- | Create JSON object from list.
fromList :: ToJson a => [(String, a)] -> Json
fromList xs = JObject $ Map.fromList (map (\(k,v) -> (k, toJson v)) xs)

-- * Union JSON objects

-- | Merge two JSON Objects.
--
--   Example:
--
-- > objA = fromList [("a", toJson "1"), ("r", fromList [("ra", "11"), ("rb", "12")])]
-- > pprint objA
-- > {
-- >   "a": "1",
-- >   "r": {
-- >     "ra": "11",
-- >     "rb": "12"
-- >   }
-- > }
-- > objB = fromList [("b", toJson "2"), ("r", fromList [("rb", "13"), ("rc", "14")])]
-- > pprint objB
-- > {
-- >   "b": "2",
-- >   "r": {
-- >     "rb": "13",
-- >     "rc": "14"
-- >   }
-- > }
-- > pprint $ objA `unionObj` objB
-- > {
-- >   "a": "1",
-- >   "b": "2",
-- >   "r": {
-- >     "ra": "11",
-- >     "rb": "12"
-- >   }
-- > }
-- > 
unionObj :: Json -> Json -> Json
unionObj (JObject x ) (JObject y)  = JObject $ Map.union x y
unionObj  x  _ = x

-- | Merge JSON objects from list.
unionsObj :: [Json] -> Json
unionsObj xs = foldl unionObj emptyObj xs

-- | Recursive merge two JSON Objects.
--
--   Example :
--
-- > objR = objA `unionRecObj` objB
-- > pprint objR
-- > {
-- >   "a": "1",
-- >   "b": "2",
-- >   "r": {
-- >     "ra": "11",
-- >     "rb": "12",
-- >     "rc": "14"
-- >   }
-- > }

unionRecObj :: Json -> Json -> Json
unionRecObj (JObject x) (JObject y) = JObject $
                 Map.unionWith (\v1 v2 -> unionRecObj v1 v2) x y
unionRecObj  x  _  = x

-- * Renders JSON to String

-- | Renders JSON to String.
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)) ++ "}"

-- * Pretty print

-- | Pretty-prints JSON.
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

-- | Pretty-prints JSONs.
pprints :: [Json] -> IO ()
pprints js = putStrLn $
    "[\n  " ++ ( intercalate "," $ map (\j -> (pprint' "  " 1 ) j) js)  ++ "\n]"

------------- private functions ----------------------------------------------

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]