module JSON (Value, json, parse, stringify) where

import Control.Monad hiding (join)
import Text.ParserCombinators.Parsec hiding (parse)
import qualified Text.ParserCombinators.Parsec as P
import Text.Printf (printf)
import Data.Char (ord, isControl)
import Data.List (intersperse)
import qualified Data.Map as M

data Value
    = String String
    | Number !Double
    | Object !(M.Map String Value)
    | Array [Value]
    | Bool !Bool
    | Null
    deriving (Eq, Show)

json :: Parser Value
json = spaces >> value

tok :: Parser a -> Parser a
tok p = do{ x <- p; spaces; return x }

value :: Parser Value
value = msum
        [ liftM String str
        , liftM Number number
        , liftM Object object
        , liftM Array  array 
        , string "true"  >> return (Bool True)
        , string "false" >> return (Bool False)
        , string "null"  >> return Null
        ]

str :: Parser String
str = between (char '"') (char '"') $ many c1
    where c1 =  satisfy (\c -> not (c=='"' || c=='\\' || isControl c))
            <|> (char '\\' >> c2)
          c2 = msum
               [ char '"'
               , char '\\'
               , char '/'
               , char 'b' >> return '\b'
               , char 'f' >> return '\f'
               , char 'n' >> return '\n'
               , char 'r' >> return '\r'
               , char 't' >> return '\t'
               , char 'u' >> do xs <- count 4 hexDigit
                                return $ read $ "\"\\x"++xs++"\""
               ]

(>>+) :: Monad m => m [a] -> m [a] -> m [a]
ma >>+ mb = ma >>= \a -> mb >>= \b -> return (a++b)

number :: Parser Double
number = liftM read $ int >>+ option "" frac >>+ option "" exp
    where digits = many digit
          int    = do s  <- option "" (string "-")
                      x  <- satisfy (`elem` ['1'..'9'])
                      xs <- digits
                      return (s++x:xs)
          frac   = char '.' >> liftM ('.':) digits
          exp    = e >>+ digits
          e      = do a <- char 'e' <|> char 'E'
                      liftM (a:) (string "+" <|> string "-" <|> string "")

object :: Parser (M.Map String Value)
object = liftM M.fromList $
         between (tok (char '{')) (char '}') $
         tok member `sepBy` tok (char ',')
    where member = do k <- tok str
                      tok (char ':')
                      v <- value
                      return (k,v)

array :: Parser [Value]
array  = between (tok (char '[')) (char ']') $
         tok value `sepBy` tok (char ',')


parse :: String -> Maybe Value
parse s = case P.parse json "JSON.parse" s of
          Left err -> Nothing
          Right v  -> Just v


stringify :: Value -> String
stringify (String s) = stringifyString s
stringify (Number x)
    | isInfinite x = error "can't stringify infinity"
    | isNaN x      = error "can't stringify NaN"
    | otherwise    = show x
stringify (Object m) = "{ " ++ join ", " [stringifyString k ++ ": " ++ stringify v | (k,v) <- M.toList m] ++ " }"
stringify (Array xs) = "[ " ++ join ", " (map stringify xs) ++ " ]"
stringify (Bool b)   = if b then "true" else "false"
stringify Null       = "null"

stringifyString :: String -> String
stringifyString s = "\"" ++ concatMap f s ++ "\""
    where f '"'  = "\\\""
          f '\\' = "\\\\"
          f '\b' = "\\b"
          f '\f' = "\\f"
          f '\n' = "\\n"
          f '\r' = "\\r"
          f '\t' = "\\t"
          f c | isControl c = printf "\\u%04x" c
              | otherwise   = [c]

join :: String -> [String] -> String
join s = concat . intersperse s