Parsing JSON data <http://book.realworldhaskell.org/read/using-parsec.html#id653027>

JSON.hs

module JSON where

import Control.Applicative hiding (many, (<|>))
import Numeric
import Text.Parsec
import Text.Parsec.String

-- http://www.ietf.org/rfc/rfc4627.txt

data JValue = JBool Bool
            | JNull
            | JObject (JObj JValue)
            | JArray  (JAry JValue)
            | JNumber Double
            | JString String
    deriving (Eq, Ord, Show)

newtype JAry a = JAry { fromJAry :: [a] }
    deriving (Eq, Ord, Show)

newtype JObj a = JObj { fromJObj :: [(String, a)] }
    deriving (Eq, Ord, Show)

p_text :: Parser JValue
p_text = spaces *> text <?> "JSON text"
  where
    text = JObject <$> p_object <|> JArray <$> p_array

p_series :: Char -> Parser a -> Char -> Parser [a]
p_series left parser right =
    between (char left <* spaces) (char right) $
            (parser <* spaces) `sepBy` (char ',' <* spaces)

p_array :: Parser (JAry JValue)
p_array = JAry <$> p_series '[' p_value ']'

p_object :: Parser (JObj JValue)
p_object = JObj <$> p_series '{' p_field '}'
  where
    p_field = (,) <$> (p_string <* char ':' <* spaces) <*> p_value

p_value :: Parser JValue
p_value = value <* spaces
  where
    value = choice [ JString <$> p_string
                   , JNumber <$> p_number
                   , JObject <$> p_object
                   , JArray  <$> p_array
                   , JBool   <$> p_bool
                   , JNull   <$  string "null"
                   ] <?> "JSON value"

p_bool :: Parser Bool
p_bool = True  <$ string "true"
     <|> False <$ string "false"

p_number :: Parser Double
p_number = do
    s <- getInput
    case readSigned readFloat s of
        [(n, s')] -> n <$ setInput s'
        _         -> empty

p_string :: Parser String
p_string = between (char '\"') (char '\"') (many jchar)
  where
    jchar = char '\\' *> (p_escape <|> p_unicode)
        <|> satisfy (`notElem` "\"\\")

p_escape :: Parser Char
p_escape = choice (zipWith decode "bnfrt\\\"/" "\b\n\f\r\t\\\"/")
  where
    decode c r = r <$ char c

p_unicode :: Parser Char
p_unicode = char 'u' *> (decode <$> count 4 hexDigit)
  where
    decode x = toEnum code
      where
        ((code, _):_) = readHex x