module Data.JSON2.Parser
  ( encodeJson
  , parseJson
  )
where
import Data.JSON2.Types
import Data.Char
import Data.Map (Map)
import qualified Data.Map as Map
import Numeric
import Control.Monad
import Text.ParserCombinators.Parsec

-- | Encode `String` to `Json`.
encodeJson :: String -> Json
encodeJson s = case parseJson s of
                 Right j -> j
                 Left  e -> error $ show e

-- | Parses JSON string.
parseJson :: String -> Either ParseError Json
parseJson s = parse jsonP' "user input" s

jsonP' = do
    spaces
    js <- jsonP
    eof
    return js
 
jsonP :: GenParser Char () Json
jsonP = (JNull   <$  tok nullP)
     <|> (JBool   <$> tok boolP )
     <|> (JString <$> tok stringP)
     <|> (JNumber . fst . head . readSigned readFloat) <$> (tok numP)
     <|> (JArray  <$> tok arrayP)
     <|> ((JObject . Map.fromList) <$> tok objectP)

nullP :: GenParser Char st String
nullP = tok (string "null")

boolP :: GenParser Char () Bool
boolP =  ( True <$ string "true") <|> (False <$ string "false")

stringP :: GenParser Char () String
stringP = char '"' >> manyTill (escCharP <|> anyChar) (char '"')
          where
            escCharP = (char '\\') >> 
              ( (char '"')         <|> (char '\\')        <|>
		(char '/')         <|> ('\b' <$ char 'b') <|>
		('\f' <$ char 'f') <|> ('\n' <$ char 'n') <|>
		('\r' <$ char 'r') <|> ('\t' <$ char 't') <|>
		(char 'u'>> uniP)
               )
            -- TODO check???  bounded .
            uniP =  (chr . fst . head . readHex) <$> (count 4 hexDigit)

numP = (try $ liftM2 (++) int frac_exp)
   <|> int
--  where
digits = many digit
digits1 = many1 digit
digit19 = oneOf "123456789"  
nat1 = consP digit19 digits
nat = ("0" <$ char '0') <|> nat1
neg = consP (char '-') nat
int = neg <|> nat
frac = consP (char '.') digits1
numz = consP (oneOf "+-") digits1
expp = consP (oneOf "eE") (numz <|> digits1)
frac_exp = (try $ liftM2 (++) frac expp)
       <|> (try  expp)
       <|> frac

arrayP :: CharParser () [Json]
arrayP = between (tok (char '[')) (tok (char ']'))
       $ jsonP `sepBy` tok (char ',')

objectP :: GenParser Char () [(String, Json)]
objectP = between (tok $ char '{' ) (tok $ char '}')
        $ pairP `sepBy` tok (char ',')
          where
            pairP = do
              k <- tok stringP
              tok $ char ':'
              v <- tok jsonP
              return (k, v)

---------------------------------------------------------------------------------
tok :: CharParser st b -> CharParser st b
tok p =  do {x <- p; spaces; return x}

consP :: CharParser () Char -> CharParser () String -> CharParser () String
consP = liftM2 (\x y -> [x] ++ y)

(<$)   :: a -> CharParser () b -> CharParser () a
x <$ m = m >> return x

(<$>)  :: (a -> b) -> CharParser () a -> CharParser () b
(<$>)   = fmap