【Haskell】ParsecでJSONパーサの作成

HaskellのParsecで、JSONパーサを作成しました。仕様はこちらを参考にしましたが、意図的に緩和した仕様があります。

• オブジェクトや配列の最後の要素の後には,が必要ですが、このパーサでは任意です
• キーは""で囲む必要がありますが、このパーサでは任意です（ただし囲っていない場合は、一文字目は英字もしくは_、2文字目以降は、英字もしくは数字、_でなければなりません）
• 同じ階層でのキー名の重複を許します
• 一番外側のデータ型は、オブジェクトでも配列でも構いません
• 整数値であっても、浮動小数点数として値を保持します

JSONパーサのソースコード

Main.hs

module Json ( parseJson ) where

import Data.Char
import Data.List
import Numeric
import Text.Parsec
import Text.Parsec.String

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

instance Show JsonValue where
    show (String s) = showJsonString s
    show (Number n) = showNumber n
    show (Boolean True) = "true"
    show (Boolean False) = "false"
    show Null = "null"
    show (Object xs) = showObject xs 1  -- 最後の1はネストの深さです
    show (Array xs) = showArray xs 1    -- こちらの1も同じです

showJsonString :: String -> String
showJsonString input =
    let (Right result) = parse (many unescaped) "" input
    in "\"" ++ concat result ++ "\""

-- 特殊文字をエスケープ形式に変換します
-- unescapedという名前は不適切かもしれません
unescaped :: Parser String
unescaped = (char '\"' >> return "\\\"")
        <|> (char '\'' >> return "\\\'")
        <|> (char '\\' >> return "\\\\")
        <|> (char '\n' >> return "\\n")
        <|> (char '\r' >> return "\\r")
        <|> (char '\t' >> return "\\t")
        <|> (char '\b' >> return "\\b")
        <|> (char '\f' >> return "\\f")
        <|> (:) <$> 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 list i = "{\n"
    ++ (intercalate ",\n" . map shown $ list)
    ++ "\n" ++ indent (i - 1) ++ "}"
    where shows (Object xs) = showObject xs (i + 1)
          shows (Array xs) = showArray xs (i + 1)
          shows x = show x
          shown (n, v) = indent i ++ show n ++ ": " ++ shows v

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

-- インデントはスペース2文字で固定になっています
-- ユーザが設定できるように、実装を変えたほうがいいかもしれません
indent :: Int -> String
indent i = replicate (i * 2) ' '

parseJson :: Parser JsonValue
parseJson = spaces *> (parseObject <|> parseArray) <* (spaces >> eof)

parseName :: Parser String
parseName = try (escapedString '"')
        <|> (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')

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

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

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

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

number :: Parser Double
number =
    -- 整数であっても、とりあえず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

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

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

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

解説と感想

input.txtというファイルにJSON文字列を保存してmain関数を実行すると、標準出力に解析結果が出力されます。ただし、特にフォーマットされていないため、出力される文字列は非常に読み辛いです…。例えば次のような文字列が出力されます。

Right (Object [NameValue "name" (String "takaya"),NameValue "age" (Number 28.0)])

パース前のJSON文字列は以下です。

{
    "name": "takaya",
    "age": 28
}

綺麗にフォーマットして表示したいのですが、まだいい案が思い浮かばないので、とりあえずこれで良しとします。

parseName関数内で、アプリカティブ・スタイルを使っています。まず:を箱の中に入れ、この関数に次々と値を渡していきます。この際に使用する関数は<$>と<*>です。使いこなせると楽しいです。

tryを使う回数をできるだけ抑えています。バックトラックの回数を抑えるためです。これがどこまで速度に影響してくるかはわかりません（笑）

String型とString値構築子が完全に別物なのが面白いです。Haskellでは、型を記述できる場所と値構築子を記述できる場所が一切重複していない故に、こういったことが可能なのだと思います。知れば知るほど、Haskellの魅力に気付かされます。

終わりに

JSON文字列を、Haskellのデータ構造に変換できるようになりました。これを応用すれば、様々なプログラミング言語をHaskellのデータ構造に変換できるようになると思います。データ変換というのは頻繁にしなければならないものなので、その中間の表現は、自分の中で決めておきたいんですよね。例えば、ExcelテーブルのデータをSQLのINSERT文に変換する際は、

Excelテーブルのデータ→Haskellのデータ構造→SQLのINSERT文

といったように、中間はHaskellのデータ構造固定といった感じで。そのためには、「文字列をパースして、Haskellのデータ構造に変換する」だけではなく、「Haskellのデータ構造から文字列を生成する」ことも必要になります。そして、今の僕にはまだそのスキルが身についていません。というわけで次は、どうすればHaskellデータ構造を文字列に変換できるかを考えていきたいと思います。これができれば、もっとプログラミングを楽しめるのではと思います。