Edited at

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

More than 1 year has passed since last update.

前回の記事には致命的なバグがありました。\uXXXXXには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メソッドも実装しました。ただ、これは少しまずかったのではと思います。ShowReadのインスタンスは、derivingで作るべきというのが今の考えです。というのも、derivingshowreadは対になっており、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に上げておくと、その心配もなくなるのではと思います。