{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE DeriveDataTypeable   #-}
module Text.HJson (
	  -- * JSON data type
	  Json(..)
	, fromString
	, toString
	, escapeJString
	, jsonParser
	  -- * Type class for objects [de]serialization
	, 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)

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

-- | Parses JSON string
fromString :: String -> Either ParseError Json
fromString s = parse valueP "user input" s

-- | Escapes string for inclusion in JSON
escapeJString :: String -> String
escapeJString = concatMap escapeJChar


----------------------------------------------------------------
-- Serialization
----------------------------------------------------------------

-- | Class of types that can be converted to or from JSON
class Jsonable a where
	-- | Convert value to JSON representation
	toJson :: a -> Json
	-- | Deserialize value. Returns Nothing in case of failure. Default
	--   implementation always returns Nothing
	fromJson :: Json -> Maybe a
	fromJson = const Nothing

-- | Newtype wrapper for list. It's user to avoid overlapping
--   instances for string
newtype List a = List { asList :: [a] } deriving (Show, Eq, Ord)

-- | Newtype wrapper for Map String a. Similarly it's used to avoid
--   overlapping instances for more generic Map a b instance.
--
--   Jsonable instance for this type require that every JSON value in
--   map should be properly decoded.
newtype Object a = Object { asMap :: Map.Map String a } deriving (Show, Eq)

-- | Another wrapper for Map String a. It have different 'Jsonable'
--   instance. Undecodable values in 'JObject' are ignored.
newtype LaxObject a = LaxObject { asLaxMap :: Map.Map String a } deriving (Show, Eq)

-- Simple, but useful
instance Jsonable Json where
	toJson   = id
	fromJson = Just
-- Numeric types
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
-- Other types
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

-- tuples
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

-- Containers
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

-- Newtype wrapped instances
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

-- private functions

-- Here I manually did instances' job. You know who to blame for its incompleteness.
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]


----------------------------------------------------------------
-- JSON parser
----------------------------------------------------------------

-- | Parsec parser for JSON
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"