Template Haskell でコード中に JSON を埋め込んだりコンパイル時にファイルから型安全に読み込んだりする
この記事は以下のページに移転しました．
前回よりはもう少し実用的な例を．
Template Haskell を使って，Haskell のコード中に JSON をそのまま埋め込むことができるようにする．また，あらかじめ用意しておいた JSON ファイルをコンパイル時に読み込み，指定したデータ型の値にする．
ToC
環境
stack --version Version 1.6.3 x86_64 hpack-0.20.0 $ stack ghc -- --version The Glorious Glasgow Haskell Compilation System, version 8.2.2 $ stack list-dependencies | grep -e aeson -e template-haskell aeson 1.2.4.0 template-haskell 2.12.0.0
1. コード中に JSON を埋め込む
準クォート (quasi quote) を使う．
前回説明した通り，クォートには以下の4種類があるのだった．
[e| ... |]- expression
Q Exp型を持つ
[d| ... |]- declarations
Q [Dec]型を持つ
[t| ... |]- type
Q Type型を持つ
[p| ... |- pattern
Q Pat型を持つ
では準クォートとは何なのか．GHC User's Guide によると，以下のように説明されている(一部抜粋)．
- 準クォートは
[quoter| string |]という形をしている quoterはインポートされた quoter の名前であるstringは任意の文字列であるquoterはLanguage.Haskell.TH.Quote.QuasiQuoter型の値である
実際に，Language.Haskell.TH.Quote 内で宣言されている QuasiQuoter 型の定義を確認してみよう．
data QuasiQuoter = QuasiQuoter { quoteExp :: String -> Q Exp, quotePat :: String -> Q Pat, quoteType :: String -> Q Type, quoteDec :: String -> Q [Dec] }
文字列を受け取って，式・パターン・型・トップレベル宣言にそれぞれ変換するものであると主張している．[quoter| string |] の string の部分が任意の文字列だったことを思い出すと，準クォートを通じてできることは，任意の文字列を受け取り，それをパーズし，Haskell のプログラムに変換することであることがわかる．つまり，パーザさえ書けば Haskell のコード中に任意の言語を埋め込めてしまう！
さて，準クォートとはなんぞやということがわかったところで，実際に quasiquoter を定義し，JSON をコード中に埋め込んでみよう．ここで JSON のパーザを用意しないといけないのだが，今回の目的は JSON のパーザを書くことではないし，自前で実装したところで performant であるとは思えないので，素直に aeson のパーザを使うことにする．
適当に stack new でプロジェクトを生成し，package.yaml の dependeicies に aeson と bytestring と template-haskell を追加する．
コードはこんな感じで．
-- src/Lib.hs {-# LANGUAGE TemplateHaskell #-} module Lib ( json ) where import Data.Aeson (eitherDecode, Value) import Language.Haskell.TH (Exp, Q) import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter, quoteExp)) import qualified Data.ByteString.Lazy.Char8 as C8 json :: QuasiQuoter json = QuasiQuoter { quoteExp = buildJSONExp . parseExp } parseExp :: String -> Value parseExp str = let result = eitherDecode (C8.pack str) in case result of Left err -> error err Right json -> json buildJSONExp :: Value -> Q Exp buildJSONExp value = [e| value |]
-- app/Main.hs {-# LANGUAGE QuasiQuotes #-} module Main where import Lib (json) main :: IO () main = print [json| { "name": "ryota-ka", "age": 24, "spouse": null } |]
実行してみる．
$ stack build && stack exec -- json-th-exe Object (fromList [("spouse",Null),("age",Number 24.0),("name",String "ryota-ka")])
Data.Aeson.Value 型の値が得られている．malformed な JSON を渡すと，きちんとコンパイル時にエラーになるはずである．(疑り深い読者の方は実際にお試しあれ！)
QuasiQuoter の4つのフィールドのうち quoteExp しか初期化していないが，Hackage にも以下のように書かれている．
if you are only interested in defining a quasiquoter to be used for expressions, you would define a
QuasiQuoterwith onlyquoteExp, and leave the other fields stubbed out with errors.
2. コンパイル時に JSON をファイルから型安全に読み込む
コード中に JSON をそのままベタ書きするのはあまり格好良くないので，JSON ファイルを用意して，コンパイル時に読み込むことにする．またその際に，Value 型ではなく，FromJSON のインスタンスである任意の型として読み込み，パーズできなかった場合にはコンパイル時にエラーを吐くようにしたい．
まずは JSON から読み込みたいデータ型を定義する．
-- src/Person.hs {-# LANGUAGE DeriveLift #-} {-# LANGUAGE OverloadedStrings #-} module Person ( Person (..) ) where import Data.Aeson ((.:), FromJSON (parseJSON), withObject) import Language.Haskell.TH.Syntax (Lift) data Person = Person { name :: String , age :: Int , spouse :: Maybe Person } deriving (Lift, Show) instance FromJSON Person where parseJSON = withObject "Person" $ \o -> Person <$> o .: "name" <*> o .: "age" <*> o .: "spouse"
Lift ってなんやねん，と思ってしまうが，焦らずに Hackage を確認すると，トップレベルにない Oxford brackets ([| ... |]) に式を埋め込む際に必要らしい．DeriveLift を有効化することでインスタンスの自動導出を行える．
次に，src/Lib.hs に以下のように書き加える*1．
diff --git a/src/Lib.hs b/src/Lib.hs index 473663e..1e6caba 100644 --- a/src/Lib.hs +++ b/src/Lib.hs @@ -1,20 +1,31 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} module Lib ( json + , loadJSONFile ) where import Data.Aeson ( eitherDecode + , FromJSON + , fromJSON + , Result (Error, Success) , Value ) import Language.Haskell.TH ( Exp , Q + , runIO ) import Language.Haskell.TH.Quote ( QuasiQuoter (QuasiQuoter, quoteExp) ) +import Language.Haskell.TH.Syntax + ( Lift + ) import qualified Data.ByteString.Lazy.Char8 as C8 @@ -30,3 +41,12 @@ parseExp str = buildJSONExp :: Value -> Q Exp buildJSONExp value = [e| value |] + +loadJSONFile :: forall a. (FromJSON a, Lift a) => FilePath -> Q Exp +loadJSONFile filename = do + str <- runIO $ readFile filename + let json = parseExp str + case fromJSON @a json of + Success x -> [e| x |] + Error err -> error err
loadJSONFile の部分だけ抜き出すと，
loadJSONFile :: forall a. (FromJSON a, Lift a) => FilePath -> Q Exp loadJSONFile filename = do str <- runIO $ readFile filename let json = parseExp str case fromJSON @a json of Success x -> [e| x |] Error err -> error err
runIO :: IO a -> Q a がミソで，コンパイル時に任意の IO 処理を実行して，Q モナドに変換することができる．強い．
最後に app/Main.hs を以下のように変更する．
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} module Main where import Lib (json, loadJSONFile) import Person (Person) person :: Person person = $(loadJSONFile @Person "person.json") main :: IO () main = print person
プロジェクトのルートディレクトリに person.json を用意してビルド，実行すると以下の通り．
$ stack build && stack exec -- json-th-exe Person {name = "ryota-ka", age = 24, spouse = Nothing}
person.json の中身の JSON を，Person 型としてパーズできないように，例えば age キーを消すなどしてやって，再度ビルドを実行すると，コンパイル時にエラーになってくれるはずだ．(こちらも疑り深い読者の方は実際にお試しあれ！)
