{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE FlexibleContexts #-}

module Text.JSONParser where

import Text.ParserCombinators.Parsec
import Data.Maybe
import Control.Monad
import Data.Char

data JValue = JObject [(JKey,JValue)]
          | JList [JValue]
          | JSingle JKey
    deriving (Read,Show)

data JKey = JKeyString String
  | JKeyNum JNum
  | JKeyBool Bool
  | JKeyNull
  deriving (Read,Show)

data JNum = JNumInt Int | JNumFraction Double
 deriving (Read,Show)

spaceOut p = between (many space) (many space) p

parseNull = string "null" >> return JKeyNull

parseKey = choice (map try [parseBool,parseString,parseNum,parseNull])

parseSingle = fmap JSingle parseKey

parseBool =  do
    b <- (string "true" <|> string "false")
    return (JKeyBool (b == "true"))

parseString = do
    char '"'
    str <- manyTill (parseEscapeChar <|> anyChar) (char '"')
    return (JKeyString str)

parseEscapeChar = do
    char '\\'
    eitherEscapeChar <- (fmap Left (char 'u' >> parseUnicodePointCode)) <|> (fmap Right (parseAsciiEscapeKey))
    let escapeSequence = case eitherEscapeChar of
          Left hexCode -> "\\x"++hexCode
          Right charKey -> "\\"++[charKey]
    return (read ("'"++escapeSequence++"'") :: Char)

parseAsciiEscapeKey = oneOf "\\/bfnrt"
parseUnicodePointCode = replicateM 4 (satisfy isHexDigit)

parseKeyValuePair = do
  k <- spaceOut parseKey
  char ':'
  o <- parseValue
  return (k,o)

parseObject = do
 char '{'
 pairs <- sepBy parseKeyValuePair (char ',')
 char '}'
 return (JObject pairs)

parseList = do
 char '['
 values <- sepBy parseValue (char ',')
 char ']'
 return (JList values)

parseValue = choice (map (try . spaceOut) [parseObject,parseList,parseSingle])

parser = do
  b <- parseValue
  eof
  return b

parseSign = char '-'
parseNatChars = many1 (oneOf "0123456789")
parseFractionalPart = char '.' >> parseNatChars
parseExponentPart = do
  oneOf "eE"
  sign <- many parseSign
  str <- parseNatChars
  return (read (sign ++ str) :: Double)

caseMaybe m f a = case m of
 (Just b) -> f a b
 _ -> a

raise n e = n * (10**e)
raiseInt n e = n * (10^(round e))

parseNum = do
  sign <- fmap maybeToList $ optionMaybe parseSign
  natpart <- parseNatChars
  fracpart <- optionMaybe parseFractionalPart
  expo <- optionMaybe parseExponentPart
  let isFractional = maybe False (<0) expo || isJust fracpart
  let fracpart' = fromMaybe "0" fracpart
  return $ JKeyNum $ case isFractional of
    True -> JNumFraction
        $ caseMaybe expo raise
        $ (read (sign++natpart++"."++fracpart'):: Double)
    False -> JNumInt
        $ caseMaybe expo raiseInt
        $ (read (sign++natpart):: Int)