{-# LANGUAGE FlexibleInstances,OverlappingInstances,TypeSynonymInstances #-}

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)

-- | 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 String Json
fromString s = either (Left . show) (Right) $ parse valueP "user input" s

-- | Escapes string for inclusion in JSON
escapeJString :: String -> String
escapeJString = concat . map (escapeJChar)

-- | Class of types that can be converted to or from JSON
class Jsonable a where
	toJson :: a -> Json
	fromJson :: Json -> Maybe a
	fromJson = const Nothing

-- Simple, but useful
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

-- private functions

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

-- Parser

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