読者です 読者をやめる 読者になる 読者になる

Template HaskellでJSONデコーダの導出

概要

最近、CodeRunnerというAIコンテストの予選BでJSONデータをいじる必要が出てきたのでHaskellJSONを読めるようにAesonを触ってみた。さらにTemplateHaskellを用いてレコード型の定義からJSONデコーダを自動導出できるようにしてみた。

背景

予選Bの問題は以下のリンクから閲覧できる。coderunner.jp

問題自体も面白いが、今回興味があるのはAPIで渡されるJSONデータである。
そのJSONは以下のような仕様になっている。

  • power: 現在の攻撃力
  • damage: 今までに与えた合計ダメージ
  • hp: 一番前の敵の体力
  • maxhp: 一番前の敵の初期体力
  • hps: 後ろにいる敵の体力の配列(戦う順に並んでいて最後に戦う敵が一番最後になる)
  • friend: 同じ部屋にいる自分以外のユーザーの配列(id昇順)
    • id: ユーザーID
    • power: そのユーザーの現在の攻撃力
    • damage: そのユーザーの今までに与えた合計ダメージ
  • log: イベントの配列(イベントは情報取得APIを前回リクエストしてから今回リクエストした間に起きたもののみを差分として表示する)
    • id: 攻撃したユーザーのユーザーID
    • enemy: 攻撃された敵のID(一番前の敵を含む残り敵数に等しい)
    • time: ためた時間[ミリ秒表記]
    • hp: 攻撃される前の敵の体力

このような構造はHaskellのレコード型を用いて自然に書くことができる。フィールド名にアンダースコアをつけているのは後でLensを使いたいからだ。

module Info where
data GameInfo = GameInfo { _myPower   :: Int
                         , _myDamage  :: Int
                         , _curHp     :: Int
                         , _maxHp     :: Int
                         , _hps       :: [Int]
                         , _friends   :: [Friend]
                         , _logs      :: [Log] }
                         deriving Show

data Friend = Friend { _friendId     :: String
                     , _friendPower  :: Int
                     , _friendDamage :: Int }
                     deriving Show

data Log = Log { _userId  :: String
               , _enemyId :: Int
               , _time    :: Int
               , _hp      :: Int }
               deriving Show

ここで問題となるのがフィールド名の衝突である。
例えばAPIの仕様では"id"というフィールド名はfriendの配列の中とlogの配列の中の両方で使われている。Haskellでは同じフィールド名を異なるレコード型に用いるためには別のファイルに記述しなければならず面倒である。同じファイルに定義する場合にはプリフィックスをつけるなどして適当に名前を変更しなければならない。

JSONのパーズ

JSONデータのパーズにはAesonというライブラリを使う。
aeson: Fast JSON parsing and encoding | Hackage
ライブラリに

decode :: FromJSON a => ByteString -> Maybe a

という関数があるので、GameInfo, Friend, LogのそれぞれをFromJSONのインスタンスにしてやれば良い。

{-# LANGUAGE OverloadedStrings #-}
import Data.Aeson
import Data.Aeson.Types

instance FromJSON Log where
    parseJSON (Object v) =
        Log <$> v .: "id"
            <*> v .: "enemy"
            <*> v .: "time"
            <*> v .: "hp"
    parseJSON invalid = typeMismatch "Log" invalid

instance FromJSON Friend where
    parseJSON (Object v) =
        Friend <$> v .: "id"
               <*> v .: "power"
               <*> v .: "damage"
    parseJSON invalid = typeMismatch "Friend" invalid

instance FromJSON GameInfo where
    parseJSON (Object v) =
        GameInfo <$> v .: "power"
                 <*> v .: "damage"
                 <*> v .: "hp"
                 <*> v .: "maxhp"
                 <*> v .: "hps"
                 <*> v .: "friend"
                 <*> v .: "log"
    parseJSON invalid = typeMismatch "GameInfo" invalid

簡単だし、typeMismatchとかいう関数を呼べばエラーメッセージもいい感じに出してくれる。
実際にパーズするのはこんな感じでできる。

import qualified Data.ByteString.Lazy as B
import Data.Aeson(eitherDecode)
import Text.Printf

testAeson :: FilePath -> (GameInfo -> IO ()) -> IO ()
testAeson path cont = do
    putStrLn $ "Case: " ++ path
    s <- B.readFile path
    case eitherDecode s of
        Left err -> putStrLn err
        Right info -> cont info

main = testAeson "sample.json" print
$ cat sample.json
{"power":2604996,"damage":40599634,"hp":13879712,"maxhp":39050001,"hps":[10857025,17480761,27899524],"friend":[{"id":"PlayerB","power":1542564,"damage":72452052},{"id":"PlayerC","power":1522756,"damage":52232156}],"log":[{"id":"PlayerC","enemy":4,"time":5017,"hp":39050001},{"id":"PlayerB","enemy":5,"time":5017,"hp":25158831},{"id":"PlayerA","enemy":5,"time":4265,"hp":43349056}]}

$ cat sample-e.json
{"power":2604996,"damage":40599634,"hp":13879712,"maxhp":39050001,"hps":[10857],"friend":[],"log":[0]}

$ ghci InfoTest.hs
GHCi, version 7.10.2: http://www.haskell.org/ghc/  :? for help
[1 of 2] Compiling Info             ( Info.hs, interpreted )
[2 of 2] Compiling Main             ( InfoTest.hs, interpreted )
Ok, modules loaded: Info, Main.
*Main> testAeson "sample.json" print
Case: sample.json
GameInfo {_myPower = 2604996, _myDamage = 40599634, _curHp = 13879712, _maxHp = 39050001, _hps = [10857025,17480761,27899524], _friends = [Friend {_friendId = "PlayerB", _friendPower = 1542564, _friendDamage = 72452052},Friend {_friendId = "PlayerC", _friendPower = 1522756, _friendDamage = 52232156}], _logs = [Log {_userId = "PlayerC", _enemyId = 4, _time = 5017, _hp = 39050001},Log {_userId = "PlayerB", _enemyId = 5, _time = 5017, _hp = 25158831},Log {_userId = "PlayerA", _enemyId = 5, _time = 4265, _hp = 43349056}]}
*Main> testAeson "sample-e.json" print
Case: sample-e.json
Error in $.log[0]: failed to parse field log: expected Log, encountered Number

Template Haskellで自動導出

上のインスタンス宣言はレコード型のフィールド名とJSONオブジェクトのレコード名の対応関係さえ与えてやれば自動導出できそうなのでやってみた。
一応aesonのライブラリ自体にもGenericを用いた自動導出とTemplateHaskellを用いた自動導出があるのだが、それらはHaskellのデータ型をイイ感じのJSONにするのには向いていても、すでにあるJSON型をデコードするのにはあまり向いていないように見えた。

自動導出器はTemplate.hsに実装した。
使い方はこんな感じである。

{-# LANGUAGE TemplateHaskell #-}
module Info where
import Template

data Log = Log { _userId  :: String
               , _enemyId :: Int
               , _time    :: Int
               , _hp      :: Int }
               deriving Show

data Friend = Friend { _friendId     :: String
                     , _friendPower  :: Int
                     , _friendDamage :: Int }
                     deriving Show

data GameInfo = GameInfo { _myPower   :: Int
                         , _myDamage  :: Int
                         , _curHp     :: Int
                         , _maxHp     :: Int
                         , _hps       :: [Int]
                         , _friends   :: [Friend]
                         , _logs      :: [Log] }
                         deriving Show

mkFromJSON ''Log [ ('_userId,  "id")
                 , ('_enemyId, "enemy")
                 , ('_time,    "time")
                 , ('_hp,      "hp") ]

mkFromJSON ''Friend [ ('_friendId,     "id")
                    , ('_friendPower,  "power")
                    , ('_friendDamage, "damage") ]

mkFromJSON ''GameInfo [ ('_myPower,  "power")
                      , ('_myDamage, "damage")
                      , ('_curHp,    "hp")
                      , ('_maxHp,    "maxhp")
                      , ('_hps,      "hps")
                      , ('_friends,  "friend")
                      , ('_logs,     "log") ]

mkFromJSONというマクロがFromJSONのインスタンスを自動導出してくれる。第一引数には導出したい型の名前、第二引数にはフィールド名の対応関係を記したリストを渡せば良い。一応簡単なエラーハンドリングもしているのでフィールド名の漏れ等も検出して教えてくれるようになっている。

Template.hsの実装はこんな感じ。TemplateHaskell触ったのは初めてだったのでチュートリアル等を見ながらなんとなく実装した。QuasiQuote使いつつやればそんなに難しくもなかった。
これらのサイトが参考になった。
できる!Template Haskell (完) - はてな使ったら負けだと思っている deriving Haskell - haskell
Language.Haskell.TH.Syntax

{-# LANGUAGE TemplateHaskell #-}
module Template(mkFromJSON) where
import Language.Haskell.TH
import Data.Aeson
import Data.Aeson.Types
import qualified Data.Text as Text
import Control.Monad

validateInfo :: Name -> [(Name,String)] -> Q Name
validateInfo name fieldmap = do
    info <- reify name
    dec <- case info of
        TyConI dec -> return dec
        _ -> fail $ nameBase name ++ " must be a type constructor"
    cons <- case dec of
        DataD _ _ _ cons _ -> return cons
        _ -> fail $ nameBase name ++ " must be a data type"
    cnstr <- case cons of
        [cnstr] -> return cnstr
        _       -> fail $ nameBase name ++ " must have only one constructor"
    (cname,fields) <- case cnstr of
        RecC cname fields -> return (cname,map (\(x,_,_) -> x) fields)
        _ -> fail $ nameBase name ++ " must be a record type"
    mapM_ (\(field,_) -> unless (field `elem` fields) $
            fail $ "invalid field name" ++ nameBase field)
          fieldmap
    mapM_ (\field -> unless (field `elem` map fst fieldmap) $
            fail $ "corresponding JSON field of the field " ++ nameBase field ++ " is not found")
          fields
    return cname

mkFromJSON :: Name -> [(Name,String)] -> Q [Dec]
mkFromJSON name fieldmap = do
    cnstr <- validateInfo name fieldmap
    vars <- mapM (\y -> (,) y <$> newName "x") fieldmap
    v <- newName "v"
    let invalid = [| typeMismatch $(stringE $ nameBase name) $(varE v) |]
        -- body = do
        --    x1 <- v .: JSONfield1
        --    x2 <- v .: JSONfield2
        --    ...
        --    xn <- v .: JSONfieldn
        --    return $ $cnstr{ field1 = x1, ... fieldn = xn }
        body = doE (stmts ++ ret)
        stmts = [ bindS (varP tvar) [| $(varE v) .: Text.pack $(stringE jsonfield)|] 
                           | ((_,jsonfield),tvar) <- vars ]
        ret = [ noBindS (appE (varE 'return) (recConE cnstr fieldDefs)) ]
        fieldDefs = [ return (field, VarE tvar) | ((field,_),tvar) <- vars ]
    [d| instance FromJSON $(conT name) where
             parseJSON (Object $(varP v)) = $body
             parseJSON $(varP v)          = $invalid |]

終わりに

実装自体は出来たが、これでコードが短くなったかと言われれば微妙だ。
使う側にOverloadedStringsとかの拡張とかライブラリのインポートをしなくても良いのが便利かもしれない。