ParsecでJSONパーサ

自分の中で何度か目のHaskellブーム到来。
パーサコンビネータ読みやすい！カッコイイ！Parsecすごい！ってなことでなんかパースする題材は無いか探し回っていた結果，JSONの仕様書が目に入ったので斜め読みしつつ実装してみました。小数の実装が怪しいけどまあいいかｗ

module JSON (
  jsNull, jsBool, jsNumber, jsString, jsArray, jsObject, jsValue, json) where

import Monad
import Data.Char
import Data.Map hiding (map)
import Text.ParserCombinators.Parsec
import Numeric

data JSON = JSNull
          | JSBool Bool
          | JSNumber Double
          | JSString String
          | JSArray [JSON]
          | JSObject (Map String JSON)
          deriving (Show, Eq)

json :: Parser JSON
json = jsObject <|> jsArray

ws = choice $ map char [' ', '\t', '\r', '\n']
wsChar c = try (many ws) >> char c >> try (many ws)

jsObject = do wsChar '{'
              vals <- try member `sepBy` try (wsChar ',')
              wsChar '}'
              return $ JSObject $ fromList vals
  where member = do
          JSString key <- jsString
          wsChar ':'
          val <- jsValue
          return (key, val)

jsArray = do wsChar '['
             vals <- jsValue `sepBy` wsChar ','
             wsChar ']'
             return $ JSArray vals

jsValue = jsBool <|> jsNull <|> jsObject <|> jsArray <|> jsNumber <|> jsString

jsNull = string "null" >> return JSNull
jsBool = (string "true" >> (return $ JSBool True)) <|>
         (string "false" >> (return $ JSBool False))

jsNumber = do
  sign <- (char '-' >> return (-1)) <|> return 1
  n    <- int
  f    <- frac <|> return 0
  e    <- exp <|> return 0
  return $ JSNumber (sign * (fromIntegral n + f) * 10 ^^ e)
  where
    foldnum = foldl1 (\x y -> x * 10 + y) . map toInteger
    digit19 = oneOf ['1' .. '9'] >>= \x -> return $ ord x - ord '0'
    digit = (char '0' >> return 0) <|> digit19
    frac = do
      char '.'
      ds <- many1 digit
      return $ (fromIntegral $ foldnum ds) * 10 ^^ (- length ds)
    exp = do
      oneOf "eE"
      sign <- (char '-' >> return (-1)) <|> (char '+' >> return 1) <|> return 1
      many1 digit >>= return . (*sign) . foldnum
    int = (char '0' >> return 0) <|> (do
      d1 <- digit19
      ds <- many digit
      return $ foldnum $ d1:ds)

jsString = between (char '"') (char '"') (many jsChar) >>= return . JSString
  where
    jsChar = unescaped <|> escaped
    unescaped = noneOf "\"\\"
    escaped = do
      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'
             >> count 4 (oneOf (['0'..'9']++['a'..'f']++['A'..'F']))
             >>= return . chr . fst . head . readHex)