blog.ryota-ka.me

Template Haskellでコード中にJSONを埋め込んだりコンパイル時にファイルから型安全に読み込んだりする

前回よりはもう少し実用的な例を．

Template Haskellを使って，Haskellのコード中にJSONをそのまま埋め込むことができるようにする．また，あらかじめ用意しておいたJSONファイルをコンパイル時に読み込み，指定したデータ型の値にする．

ToC#

  1. コード中にJSONを埋め込む
  2. コンパイル時にJSONをファイルから型安全に読み込む

環境#

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を渡すと，きちんとコンパイル時にエラーになるはず*1である．

QuasiQuoterの4つのフィールドのうちquoteExpしか初期化していないが，Hackageにも以下のように書かれている．

if you are only interested in defining a quasiquoter to be used for expressions, you would define a QuasiQuoter with only quoteExp, 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に以下のように書き加える*2．

src/Lib.hs
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を以下のように変更する．

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キーを消すなどしてやって，再度ビルドを実行すると，コンパイル時にエラーになってくれるはず*3だ．

ソースコード#

脚注#

*1: 疑り深い読者の方は実際にお試しあれ！

*2: parseExp関数を使い回しているが，かつてはOxford bracketsの中のexpressionをparseする関数だったのが，今ではファイルから得られた文字列のパーズに使っているので，名前として不適な感はある．

*3: こちらも疑り深い読者の方は実際にお試しあれ！