-----------------------------------------------------------------------------
-- |
-- Module      :  JSON
-- Copyright   :  (c) Masahiro Sakai & Jun Mukai 2006
-- License     :  BSD-style
-- 
-- Maintainer  :  sakai@tom.sfc.keio.ac.jp
-- Stability   :  experimental
-- Portability :  portable
--
-----------------------------------------------------------------------------

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

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

-- ---------------------------------------------------------------------------
-- The Value data type

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

{-
instance Show Value where
    showsPrec p = showsPrec p . toDoc
-}

-- ---------------------------------------------------------------------------
-- The JSON Parser

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

json :: Parser Value
json = spaces >> tok 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++"'"
               ]

number :: Parser Double
number = liftM read $ int >>+ option "" frac >>+ option "" exp
    where digits = many1 digit
          int    = option "" (string "-") >>+ digits
          frac   = char '.' >>: digits
          exp    = e >>+ digits
          e      = oneOf "eE" >>: option "" (string "+" <|> string "-")
          (>>+)  = liftM2 (++)
          (>>:)  = liftM2 (:)

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 ',')

-- ---------------------------------------------------------------------------
-- The JSON Printer

stringify :: Value -> String
stringify = show . toDoc

toDoc :: Value -> Doc
toDoc (String s) = strToDoc s
toDoc (Number x)
    | isInfinite x = error "can't stringify infinity"
    | isNaN x      = error "can't stringify NaN"
    | otherwise    = double x
toDoc (Object m) = lbrace <+> join comma [fsep [strToDoc k <> colon, nest 2 (toDoc v)] | (k,v) <- M.toList m] $+$ rbrace
toDoc (Array xs) = lbrack <+> join comma (map toDoc xs) <+> rbrack
toDoc (Bool b)   = text $ if b then "true" else "false"
toDoc Null       = text "null"

strToDoc :: String -> Doc
strToDoc = doubleQuotes . text . concatMap f
    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 :: Doc -> [Doc] -> Doc
join s = fcat . punctuate s