json-parser.hs

-- Released to the public domain January 2, 2012.
module Main(main) where

import Control.Monad
import Data.Char
import Data.Maybe
import Data.List
import Text.Parsec
import Text.Parsec.String

data JValue = JObject [(String, JValue)]
            | JArray [JValue]
            | JString String
            | JNumber Double
            | JTrue | JFalse
            | JNull
    deriving Show

whitespaceChar = oneOf " \n\r\f" >> return ()
              <?> "whitespace character"

ws = skipMany whitespaceChar <?> "whitespace"

tok = between ws ws . char

beginArray     = tok '['
beginObject    = tok '{'
endArray       = tok ']'
endObject      = tok '}'
nameSeparator  = tok ':'
valueSeparator = tok ',' <?> "comma"

true = string "true" >> return JTrue
false = string "false" >> return JFalse
jnull = string "null" >> return JNull

object :: Parser JValue
object = (liftM JObject . between beginObject endObject $ member `sepBy` valueSeparator)
      <?> "object"
    where
        member = do (JString name) <- jstring
                    _ <- nameSeparator
                    v <- jvalue
                    return (name, v)
                 <?> "member"

array :: Parser JValue
array = (liftM JArray . between beginArray endArray $ jvalue `sepBy` valueSeparator)
     <?> "array"

jstring :: Parser JValue
jstring = (liftM JString . between quote quote $ many character)
       <?> "string"
    where
        quote = char '"'
        character = unescaped <|> escaped
        escaped = do _ <- char '\\'
                     c <- oneOf $ 'u' : map fst escapables
                     if c == 'u' then readHex else readNormal c

        readHex = do ds <- count 4 hexDigit -- contains 4 hex digits, as characters.
                     let ds' = zip (reverse [0..3]) $ map digitToInt ds
                      in return . toEnum $ foldl' (\n (e, d) -> n+d*0x10^e) 0 ds'

        readNormal c = return . fromJust $ lookup c escapables

        unescaped :: Parser Char
        unescaped = satisfy (valid . ord)
            where
                valid c = 0x20 <= c && c <= 0x21
                       || 0x23 <= c && c <= 0x5B
                       || 0x5D <= c && c <= 0x10FFFF

        escapables = [ ('"', '"')
                     , ('\\', '\\')
                     , ('b', '\b')
                     , ('f', '\f')
                     , ('n', '\n')
                     , ('r', '\r')
                     , ('t', '\t')
                     ]

number :: Parser JValue
number = do s1 <- readSign
            n <- rawNum
            f <- option "0" $ char '.' >> rawNum
            (expon, s2) <- option ("0", '+') expo
            let s = [s1] ++ n ++ "." ++ f ++ "e" ++ [s2] ++ expon
            return . JNumber $ read s
          <?> "number"
    where
        readSign = liftM (\c -> if c == '+' then ' ' else c) $ option '+' sign
        expo = do _ <- oneOf "eE"
                  s <- readSign
                  ex <- rawNum
                  return (ex, s)
        rawNum = many1 digit
        sign = oneOf "+-" <?> "sign"

jvalue :: Parser JValue
jvalue = object
      <|> true <|> false
      <|> jnull
      <|> array
      <|> number
      <|> jstring

parseJSON :: Parser JValue
parseJSON = object <|> array

--simpleTest = readFile "simple.json"
--arrayTest = readFile "array.json"
--objectTest = readFile "object.json"

main :: IO ()
main = parseTest parseJSON "{\"x\":1 }"
-- OUTPUT:
-- parse error at (line 1, column 8):
-- unexpected "}"
-- expecting whitespace character or ","