実は persistent のスキーマ定義で、テーブル名の横に json と書くだけで ToJSON, FromJSON が定義されることが判明

な、なんだってー (AA略
きっかけは昨日の yesod 勉強会での @ffu_ さんの発表 https://speakerdeck.com/u/fujimura/p/scotty-aeson-persistentjson-web-api
詳しくはスライドを見てもらうとして、要約すると persistent で自動的にテーブル定義に対応して生成されるデータ型を ToJSON, FromJSON のインスタンスにしてやれば RESTful な JSON API が簡単に作れるよねという感じだろうか。
しかし、いちいち ToJSON, FromJSON のインスタンスにしてやるのは大変面倒なので、 どうせなら TemplateHaskell で自動的に生成できたら嬉しいんじゃないかという話になった。
そんなこんなでつらつらと persistent のソースコードを眺めていたら、 mkJSON などという関数を発見してしまったわけです。 発見した当初は驚きのあまり現行のバージョンだとまだモジュールからエクスポートされていないので、 使えない実験的な機能なのかと誤読してましたが、実は現行のバージョンで既に使えることが判明。
使い方は簡単。テーブル名の横に json と書き加えるだけ。

share [mkPersist sqlSettings] [persist|
Person json
name Text
|]
これだけで、Person は ToJSON, FromJSON のインスタンスになる。 こんな機能ドキュメントや yesod blog とかで見た記憶はないのですが……
せっかくなので実装をちょっとだけ追ってみます。


当然 TemplateHaskell まみれなので、 @mr_konn さんの できる!Template Haskell (完) あたりを参考にしながら読むと良いでしょう。
準クォート [persist| ... |] で DB スキーマを表す DSL から EntityDef を生成し、それを share に渡しています。
では share 関数の定義から見てみましょう。

share :: [[EntityDef] -> Q [Dec]] -> [EntityDef] -> Q [Dec]
share fs x = fmap mconcat $ mapM ($ x) fs
share 関数は割と簡単で、EntityDef を受けとって何かしらの宣言のリスト [Dec] を返す関数のリスト [[EntityDef] -> Q [Dec]] を受けとり、 EntityDef にその関数を作用させて、結果を mconcat で結合しているだけの関数です。 したがって、自分の好きな [EntityDef] -> Q [Dec] な関数を作って share に渡してやれば、 自由にインスタンス定義することができます。 なお、構文木の接合を行なう際は $( ) で囲む必要がありますが、 トップレベル宣言の場合は省略することが出来ることに注意してください。
先程のテーブル定義を見ると、share の第一引数に [mkPersist sqlSettings] が渡されていることから、 実際にデータ型やインスタンス定義を行なっているのは mkPersist 関数であることが分かります。 そこで、次は mkPersist を覗いてみることにします。
mkPersist :: MkPersistSettings -> [EntityDef] -> Q [Dec]
mkPersist mps ents = do
x <- fmap mconcat $ mapM persistFieldFromEntity ents
y <- fmap mconcat $ mapM (mkEntity mps) ents
z <- fmap mconcat $ mapM mkJSON ents
return $ mconcat [x, y, z]
mkPersist は EntityDef に対して mkJSON を適用しているので、mkJSON の中を見ることにします。 mkJSON の冒頭部分は
mkJSON :: EntityDef -> Q [Dec]
mkJSON def | not ("json" `elem` entityAttrs def) = return []
mkJSON def = do
となっています。 時間が無いので今回は persist のパーサ部分については割愛しますが、 実は、テーブル名の横に空白区切りで文字列を書くと、 それが EntityDef の entityAttrs にリストとして格納されるように [persist| |] は定義されています。
mkJSONEntityDef のフィールド entityAttrs"json" が含まれているときのみ、 ToJSON, FromJSON のインスタンス生成を行なうことが冒頭部分より分かります。
では、mkJSON のインスタンス生成部分を追ってみることにします。
mkJSON def = do
pureE <- [|pure|]
apE' <- [|(<*>)|]
packE <- [|pack|]
dotEqualE <- [|(.=)|]
dotColonE <- [|(.:)|]
dotColonQE <- [|(.:?)|]
objectE <- [|object|]
obj <- newName "obj"
mzeroE <- [|mzero|]
[| ... |] で囲まれた部分は式クォート [e| .. |] の省略形で、 ... に書いた部分をパースして構文木に変換してくれるものです。
なぜこのような物を使うかというと、生の構文木は複雑で読みにくいうえに、 GHC構文木GHC バージョンに依って変化するという厄介な問題があるため、 式クォートなどを使って書くことで、可読性を高め、バージョン依存性を減らすことをができるからです。
Database/Persist/TH.hs#L734:
xs <- mapM (newName . unpack . unHaskellName . fieldHaskell)
$ entityFields def
entityFields defEntityDef から DB のカラム定義を取り出し、 それに unpack . unHaskellName . fieldHaskell を作用させて文字列に変換したものを newName に渡しています。 newName は String を受けとって、それを元に一意な名前を作って返す関数です。 xs は後ほど変数名として使われる名前のため、他の定義と重複しないように一意な名前を作って返す newName を使っています。 newName について詳しくは先程も出てきた @mr_konn さんの blog を参照してください。
実際のインスタンス定義作成部分を見る前に、 先程のテーブル定義にあった Person を例として、 persistent がどのような型を生成しているかについて触れておくことにします。 実は、作成された Person は PresonGeneric SqlPersist の型シノニムで、
data PersonGeneric backend =
{ name :: String
}
type Person = PersonGeneric backend
のような定義が persistent によって作成されています。 この PersonGeneric は、実際のデータ定義には出てこない backend という型引数を取っています。 これは [Phantom type][] と呼ばれる技法で、これを用いるとデータにタグを付けることが出来ます。
この PersonGeneric backend に対するインスタンスを定義する前に、 まずは、PersonGeneric backend 型を表わす名前を作ってやる必要があります。
let con = ConT $ mkName $ unpack
(unHaskellName (entityHaskell def) ++ "Generic")
conName = mkName $ unpack $ unHaskellName $ entityHaskell def
typ = con `AppT` VarT (mkName "backend")
conPersonGeneric を表わします。ここでは、既存の名前を参照するため mkName を使い、型構築子を表わす ConT で包んでいます。 同様に conNamePerson を表します。 VarT (mkName "backend") で型変数 backend を作り、AppTcon を作用させて PersonGeneric backend 型を表わす typ を作ることができました。
ここまでくれば、後はインスタンスの Q [Dec] を作ってやるだけです。 インスタンスを作るには、InstanceD を使います。
let toJSONI = InstanceD
[]
(ConT ''ToJSON `AppT` typ)
[toJSON']
toJSON' = FunD 'toJSON $ return $ Clause
[ConP conName $ map VarP xs]
(NormalB $ objectE `AppE` ListE pairs)
[]
pairs = zipWith toPair (entityFields def) xs
toPair f x = InfixE
(Just (packE `AppE` LitE (StringL $ unpack $ unHaskellName $ fieldHaskell f)))
dotEqualE
(Just $ VarE x)
InstanceD の引数は、それぞれインスタンス制約、インスタンス宣言本体、メンバ函数の定義となっています。 toJSONI を見てやると、インスタンス制約は特に無し、メンバ関数として toJSON' で定義されている関数を持つことがわかります。 では、インスタンス宣言本体に出てくる ''ToJSON とは一体なんでしょうか。 ''ToJSON は型名クォートと呼ばれるもので、(mkName "ToJSON") と等価です。 ToJSON と直に書いてしまうと式と見做されてしまうのでクォートしてやる必要があります。 文字列から名前を生成する必要が無いのであれば、こちらの方が便利でしょう。
最後に toJSON' の中身を見てみます。 FunD はもちろん関数の構文木で、関数名と本体を引数に取ります。 'toJSON は関数クォートで、型名クォートと似た働きをします。
関数本体は Clause を使って作ります。 Clause は引数のパターン、関数本体、where 節の順に引数を取ります。 xs がカラム名を元に作られた変数名ということを思い出すと、 ConP conName $ map VarP xs は型構築子 conName に対してパターンマッチを行ない、 xs にある名前に束縛するということを意味します。
最後に関数本体です。NormalB は Body 型のデータ構築子で、 Body 型は、他に GuardB データ構築子を持つことから分かる通り、 NormalB はガードを持たない通常の関数定義を表すことがわかります。 この中身は、先に [|object|] で定義した objectE を ListE pairs に適用していています。 ListE pairs は pairs を要素に持つリストを表わしています。
InfixE演算子を表わす構文木です。第一、第三引数が Maybe なのは (2 +) などを表現できるようにするためです。 pairs はカラム名とそれに対応する変数名を dotEqualE の両辺に渡した形になっています。
したがって、生成されたインスタンス
instance ToJSON (PersonGeneric backend) where
toJSON (Person name) = object [ "name" .= name ]
のような定義になっていることが推測できます。 すごいシンプルですね(棒
TemplateHaskell を読む分にはまだなんとかなりますが、 これを自分で書けとか言われても……と思うかもしれませんが、 準クォート
  • 宣言クォート [d| ... |]
  • 式クォート [e| ... |]
  • パターンクォート [p| ... |]
  • 型クォート [t| ... |]
あたりを駆使して構文木を見ながら作れば意外となんとかなるものです。たぶん。