【Haskell】ParsecでJSONパーサの作成〜改善版〜

前回の記事には致命的なバグがありました。\uXXXX（Xには16進数の数字が入る）という文字が文字列に含まれているとき、パースエラーになります。

そんなわけで、コードを書き直しました。コメントも少し入れました。

Json.hs

module Json ( parseJson ) where

import Prelude hiding (showString)
import Data.Char (chr)
import Data.List (intercalate)
import Numeric (readHex)
import Text.Parsec
import Text.Parsec.String

data JsonValue = String String
               | Number Double
               | Object [(String, JsonValue)]
               | Array [JsonValue]
               | Boolean Bool
               | Null

-- これがトップレベルのパーサです
-- トップレベルは、オブジェクト形式もしくは配列形式です
parseJson :: Parser JsonValue
parseJson = spaces *> (parseObject <|> parseArray) <* (spaces >> eof)

-- 空文字のキー名を受け付けるようになっています
-- あまりよくないかもしれません
parseName :: Parser String
parseName = try (parseChar '"')
        -- キー名がダブルクォートで囲まれていなくても、エラーは発生しません
        <|> (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')

parseChar :: Char -> Parser String
parseChar c =
    char c *> many (escapedChar <|> noneOf [c]) <* char c
    where escapedChar = char '\\' >>
               ((char '\"' >> return '\"')
            <|> (char '\\' >> return '\\')
            <|> (char 'b'  >> return '\b')
            <|> (char 'f'  >> return '\f')
            <|> (char 'n'  >> return '\n')
            <|> (char 'r'  >> return '\r')
            <|> (char 't'  >> return '\t')
            -- '\u5948'を'奈'へ変換します
            <|> (char 'u'  >> chr . fst . head . readHex <$> count 4 hexDigit))

parseNumeric :: Parser Double
parseNumeric =
    -- 整数であっても、とりあえずDouble型で値を保持します
    (**) <$> numeric <*> option 1 (oneOf "eE" >> numeric)
    where numeric = do
            sig <- string "-" <|> optional (string "+") *> return ""
            fst <- many1 digit
            snd <- option "" $ (:) <$> char '.' <*> many1 digit
            return . read $ sig ++ fst ++ snd

parseNameValue :: Parser (String, JsonValue)
parseNameValue = do
    name <- parseName
    spaces >> char ':' >> spaces
    value <- parseJsonValue
    return (name, value)

parseJsonValue :: Parser JsonValue
parseJsonValue = parseString
             <|> parseNumber
             <|> parseObject
             <|> parseArray
             <|> parseBoolean
             <|> parseNull

parseString :: Parser JsonValue
parseString = String <$> parseChar '"'

parseNumber :: Parser JsonValue
parseNumber = Number <$> parseNumeric

parseObject :: Parser JsonValue
parseObject = do
    char '{' >> spaces
    -- 最後の要素の後ろのカンマは、あってもなくても構いません
    nameValues <- (parseNameValue <* spaces) `sepEndBy` (char ',' >> spaces)
    char '}'
    return $ Object nameValues

parseArray :: Parser JsonValue
parseArray = do
    char '[' >> spaces
    -- 最後の要素の後ろのカンマは、あってもなくても構いません
    values <- (parseJsonValue <* spaces) `sepEndBy` (char ',' >> spaces)
    char ']'
    return $ Array values

parseBoolean :: Parser JsonValue
parseBoolean = do
    bool <- try (string "true") <|> try (string "false")
    return $ Boolean (bool == "true")

parseNull :: Parser JsonValue
parseNull = try (string "null") >> return Null

前回の記事ではMain.hsにパーサを実装していたのですが、今回はJson.hsに分離しました。こうすることで、JSONパーサがライブラリとしてすぐにでも公開できるようになります。

Show.showメソッドも実装しました。ただ、これは少しまずかったのではと思います。ShowとReadのインスタンスは、derivingで作るべきというのが今の考えです。というのも、derivingのshowとreadは対になっており、showで文字列化したものをパイプラインで渡すことで、受け取り側はreadで簡単にHaskellデータ構造に復元できます。それに、独自のshowの実装は、インデント幅を指定できません。これは、showの型がa -> Stringと決まっているからです。というわけで、a -> Int -> Stringのような関数を新たに作ったほうがいいのでは？と今は思っています。

-- Show.show の型は a -> String と決まっているため、インデント幅の指定はできません
-- 表示形式を指定するためには、新たにshowJsonなどの関数を定義する必要があるでしょう
instance Show JsonValue where
    show (String s) = showString s
    show (Number n) = showNumber n
    show (Object xs) = showObject xs 1  -- 最後の1はネストの深さです
    show (Array xs) = showArray xs 1    -- こちらの1も同じです
    show (Boolean True) = "true"
    show (Boolean False) = "false"
    show Null = "null"

-- Show.showをそのまま使わない理由は、Show.showを使うと、
-- '奈'などの文字が'\22856'と変換されて表示されるためです
showString :: String -> String
showString input =
    let (Right result) = parse (many decode) "" input
    in "\"" ++ concat result ++ "\""
    where decode =  (char '\"' >> return "\\\"")
                -- 特殊文字はエスケープ形式に変換します
                <|> (char '\\' >> return "\\\\")
                <|> (char '\b' >> return "\\b")
                <|> (char '\f' >> return "\\f")
                <|> (char '\n' >> return "\\n")
                <|> (char '\r' >> return "\\r")
                <|> (char '\t' >> return "\\t")
                -- 日本語であっても、'\uXXXX'形式に変換しません
                <|> (:) <$> anyChar <*> return ""

showNumber :: Double -> String
-- 切り上げた値と切り捨てた値が一致すれば、整数と見なします
-- 整数であれば、小数点以下を表示しません
showNumber n = if ceiling n == floor n
                then show (floor n :: Int)
                else show n

showObject :: [(String, JsonValue)] -> Int -> String
showObject []   i = "{}"
showObject list i = "{\n"
    -- この辺り、リストの連結をしているので、速度が怪しいです
    ++ (intercalate ",\n" . map shown $ list)
    ++ "\n" ++ showIndent (i - 1) ++ "}"
    where shows (Object xs) = showObject xs (i + 1)
          shows (Array xs) = showArray xs (i + 1)
          shows x = show x
          shown (n, v) = showIndent i ++ show n ++ ": " ++ shows v

showArray :: [JsonValue] -> Int -> String
showArray []   i = "[]"
showArray list i = "[\n"
    ++ (intercalate ",\n" . map shown $ list)
    ++ "\n" ++ showIndent (i - 1) ++ "]"
    where shows (Object xs) = showObject xs (i + 1)
          shows (Array xs) = showArray xs (i + 1)
          shows x = show x
          shown v = showIndent i ++ shows v

-- インデントはスペース2文字で固定になっています
showIndent :: Int -> String
showIndent i = replicate (i * 2) ' '

コードだけ載せる記事でごめんなさい。Haskellで書かれたコードがあまりに簡潔でして…その簡潔さを広めたいのと、もう二度とJSONパーサをParsecで作らないようにするためです。過去にも一度、HaskellでJSONパーサを作ったことがあるのですが、コードをなくしてしまいました。Qiitaに上げておくと、その心配もなくなるのではと思います。