できる！Template Haskell（完） konn-san.com

Template Haskell とは？── TH で出来ること

Template Haskell とは、Haskellで ² コンパイル時メタプログラミングを行うための仕組みです。

……何だかよくわかりませんね。Template Haskell（以下 TH と略）とはマクロの一種です。マクロっていうのは、三崎漁港で取れるお魚のことではなく、簡単に云うとプログラムを生成するためのプログラムです。

そんな事をして何が嬉しいのか？例えば応用例としてはこんなことが出来ます：

• 型クラスインスタンス宣言の自動生成
• 他言語とのブリッヂの自動生成
• 準クォートによるリーダマクロ³
• などなど……

これらを総合して、「何らかのパターンのある記述を自動的に生成することができる」と云うことになるでしょうか。こういうのをboilerplate と云うそうです。

次のような事は出来ません：

• 型システムを拡張する
• 彼女

さて。生成すると云いましたが、実際にはHaskellプログラムの構文木をコンパイル時に組替え・合成して、それをその場に埋め込むと云う形になっています。

と云うことで、THを使いこなすことと云うのは、構文木を適切に合成すること、と云い換えることが出来るでしょう。幾つか構文木の例を見ていきましょう。

例1：

putStrLn "hello, TH World！"

AppE (VarE 'putStrLn) (LitE (StringL "hello, TH World！"))

例2：

fact 0 = 1
fact n = n * fact (n - 1)

[FunD 
  (mkName "fact")
  [ Clause [LitP (IntegerL 0)] (NormalB (LitE (IntegerL 1))) []
  , Clause [VarP $ mkName "n"] 
      (NormalB 
        (InfixE 
          (Just (VarE $ "n"))
          (VarE '(*))
          (Just 
            (AppE (VarE $ mkName"fact") 
              (InfixE 
                (Just (VarE $ mkName "n")) 
                (VarE '(-)) 
                (Just (LitE (IntegerL 1)))
              )
            )
          )
        )
      ) 
      []
  ]
]

例3：

data MyGreatData = MGD String Int

DataD [] (mkName "MyGreatData") [] 
  [NormalC (mkName "MGD") [(NotStrict, ConT ''String),(NotStrict, ConT ''Int)]]
  []

どう？簡単でしょう？

Template Haskell ことはじめ

……はい。全然簡単じゃないですね。僕もそう思います。「こんなの一々書かなきゃいけないなら TH いいや……」と云う声も聴こえてきそうです。

また更に、この構文木はええと GHC 7.0.4 標準添付の template-haskell-2.5.0.0 準拠の物です。これはどういうことかと云うと、将来のバージョンで構文木が変わるかもしれない、と云うことです。

うひゃあ、そんなの追随出来る訳ないじゃんどうするの……と云う感じです。生構文木とか書ける気がしないし、構文木も変わっちゃうんじゃあ……。

しかーし。問題はありません。TH を使う場合、簡単な例であれば生の構文木を書かないで済ませることが出来ます。また、生の構文木を書く場合も簡単にその構文木を書き下すことが出来る方法があります。

それを、これから解説していきたいと思います。

ghc-pkg list template-haskell

ghci -XTemplateHaskell

TH の仕組みと実際の手順

$ ghci -XTemplateHaskell -XQuasiQuotes 
GHCi, version 7.0.4: http://www.haskell.org/ghc/  :? for help
Loading package ghc-prim ... linking... done.
Loading package integer-gmp ... linking ... done.
Loading package base. .. linking ... done.
Loading package ffi-1.0 ... linking ... done.
Loading package filepath-1.2.0.0 ... linking ... done.
Loading package old-locale-1.0.0.2 ... linking ... done.
Loading package old-time-1.0.0.6 ... linking ... done.
Loading package unix-2.4.2.0 ... linking ... done.
Loading package directory-1.1.0.0 ... linking ... done.
Loading package process-1.0.1.5 ... linking ... done.
Prelude> :m Language.Haskell.TH

putStrLn  "hello, TH World！"

Prelude Language.Haskell.TH> runQ [e|putStrLn "hello, TH World！"|]
AppE (VarE System.IO.putStrLn) (LitE (StringL "hello, TH World！"))

Prelude Language.Haskell.TH> let expr = AppE (VarE System.IO.putStrLn) (LitE (StringL "hello, TH World！"))

<interactive>:1:23:
Couldn't match expected type `Name' with actual type `String -> IO ()'
  In the first argument of `VarE', namely `putStrLn'
  In the first argument of `AppE', namely `(VarE putStrLn)'
  In the expression:
    AppE (VarE putStrLn) (LitE (StringL "hello, TH World！"))

Prelude Language.Haskell.TH> let expr = AppE (VarE 'putStrLn) (LitE (StringL "hello, TH World！"))

> let expr = AppE (VarE 'putStrLn) (LitE (StringL "hello, TH World！"))
> ppr expr
System.IO.putStrLn "hello, TH World！"

例1：任意長タプルを扱う函数

それではさっそく例を見ていきましょう。THの入門記事や紹介では必ずといっていいほど紹介されている、任意長タプルを扱う函数をここでも扱ってみたいと思います。

ここでいう任意長タプルを扱う函数、と云うのは、 二要素タプルに対する fst や sndのようなものを、任意長のタプルについて定義してあげよう！と云うことです。

次のような感じにしたいですね。

sel
  :: Int  -- ^ タプルの要素数
  -> Int  -- ^ 取り出したいタプルの要素の番目
  -> ExpQ -- ^ 函数を表わす構文木
sel len nth = ...

返値の ExpQ は Q Exp の型シノニムです。

使い方としては、sel から返された構文木を接合して、実際の函数として使ってやる形になります。

……あ、そうそう、構文木の接合をどうやるかという方法を説明していませんでしたね。合成した構文木を埋め込むには、$( ) で囲めばよいのです。そう、次のように（GHCi のプロンプトで試している想定です）：

> $(sel 3 2) (1, 2, 3)
2

また、接合したい式が単なる名前一つだけで済む場合、つまり、

hoge = $(fuga)

の様な場合は

hoge = $fuga

と書き直すことが出来ます。ここがややこしく、僕らの大好きな中置 演算子 ($) と混同しやすいです。 Haskell のパーザは、$ の後にスペースが開いていれば演算子、そうでなければ接合と解釈するので気を付けましょう。THのコードを書く際には、なるべく($) を使わない方がよいかもしれません。

このように式や型を接合する際には$()が必要ですが、トップレベル宣言の接合の場合は $( ) を省略することが出来ます。その例は後程インスタンス生成の例で見ていきたいと思います。

構文木の接合は、普通の Haskell のソース中にも書けますし、更に式クォートや型クォートの中にも書くことが出来ます。普通のソース中への接合を特にトップレベル接合と云います。

構文木を接合する際に一つ、Stage Restriction と云う制限があります。これはトップレベル接合では同一モジュール内の函数や引数を参照出来ないという制限です(式クォート中であれば問題ありません)。これについては後の落とし穴のコーナーで言及します。

閑話休題。先程から sel の返値を「函数」と呼んできましたが、実際には「式」がそこに接合されることになるので、実際にはラムダ式がそこにくることになります。

さて、では sel の実装に入りましょう。知るべきことは何でしょう？

1. ラムダ式を表わす構文木は？
2. タプルを表わす構文木は？
3. 変数を表わす構文木は？

こんな所でしょうか。これらを一つずつ調べてもいいですが、今生成したいのはラムダ式だったので、目的のラムダ式と似たようなラムダ式、例えば \(x,y,z) -> y の構文木を表示させて仕舞えば簡単ですね。

では、 GHCi を起動してください。 -XTemplateHaskell をつけて起動して、Language.Haskell.TH を読み込むのを忘れずに。

$ ghci XTemplateHaskell 
GHCi, version 7.0.4: http://www.haskell.org/ghc/  :? for help
...
Prelude> :m Language.Haskell.TH
Prelude Language.Haskell.TH> 

では、構文木を表示させてしまいましょう。

> runQ [|\(x,y,z) -> y |]
LamE [TupP [VarP x_0,VarP y_1,VarP z_2]] (VarE y_1)

大体形が予想出来たと思います。ラムダ式を表わす構文木(の構築子名)が LamE、タプルのパタンを表わす構文木が TupP、変数のパタンおよび式を表わすのが VarP および VarE です。

ここから大体想像がつくと思いますが、構文木のデータ構築子には、それが何を表わす構文木なのかを示す接尾辞が付いています。式ならば大文字のE、パタンなら P、型はT、宣言は D 、といった具合です。

なお、上式中の x_0, y_1, z_2 はそれぞれ Name です。

さて、ではこれを参考に sel を実装していきましょうー。

はい、既に実装したものが実は下にあります (TupTH.hs) ！

module TupTH where
import Language.Haskell.TH
import Control.Monad

sel :: Int -> Int -> ExpQ
sel count nth = do
  vars <- replicateM count $ newName "x"
  lamE [tupP $ map varP vars] (varE $ vars !! (nth-1))

sel の定義一行目では、タプルの各要素に使われる名前を生成しています。ここで登場する newName と云うのは、その型

> :t newName
newName :: String -> Q Name

からもわかるとおり、文字列を取ってそれを元に名前を作って返す函数です。あれ、でも最初の方で mkName と云う函数が出て来ていましたね。あれはどうちがうんでしょう……？型は、、、

> :t mkName
mkName :: String -> Name

newName とそっくりですね。でもよく見ると返値が Q で包まれていません。

この違いはなにか？次を試してみるとわかります。

> $(varE $ mkName "pi")
3.141592653589793

> $(varE =<< newName "pi")
<interactive>:1:3:
    Not in scope: `pi[a19D]'
    In the result of the splice:
      $(varE =<< newName "pi")
    To see what the splice expanded to, use -ddump-splices
    In the expression: $(varE =<< newName "pi")
    In an equation for `it': it = $(varE =<< newName "pi")

このように、mkName で作られたものは 文脈 中に被る名前があればそれを参照しますが、newName は完全にフレッシュな、衝突しない名前を返します。これが出来るのは、 Q モナド に包まれているからです。上のエラーをよくみると、Not in scope: `pi[a19D]' となっていますね。newName で生成された識別子は厳密には pi ではなく pi[a19D] と云う名前であることになっていて、後ろの [ ] に囲まれた部分がその一意性を保証している訳です。

sel の例では、newName を count 回繰り返してフレッシュな名前を count 個得ています。逆に上の vars を定義している部分を、

let vars = replicate count $ mkName "x"

に差し替えると、sel の定義を読み込んだ時点ではエラーは出ませんが、それを接合しようとすると、、、

> $(sel 3 2) (1,2,3)

<interactive>:1:3:
    Conflicting definitions for `x'
    Bound at: <interactive>:1:3-9
              <interactive>:1:3-9
              <interactive>:1:3-9
    In a lambda abstraction
    In the result of the splice:
      $(sel 3 2)
    To see what the splice expanded to, use -ddump-splices
    In the expression: $(sel 3 2)

こんな具合に mkName で生成されている名前が被ってしまっているのでエラーが出ます。つまり、

\(x,x,x) -> x

のような何が何やらよくわからない式になってしまっているので、弾かれて仕舞うわけです。

ここで一つポイントなのが、このエラーが出るのは 接合されるとき だということです。函数としては型があってしまえば構文木としてはまったく問題ないので、それが実際に式へと変換されて始めてエラーがおきるのです。

では二行目に移りましょう。ここではさっき確認した構文木を参考に、ラムダ式を表わす構文木を生成しているところです。

lamE [tupP $ map varP vars] (varE $ vars !! (nth-1))

一行目で生成した vars はあくまで名前のリストだったので、引数パタンがくる部分では map varP で名前を参照するパターンに、第二引数の実際の式の部分では $n$-番目の引数に varE を付けて式に変換しています。

さて。注意深くみてみると、おや？と思われたひとも多いと思います。さっきみた構文木では LamE や VarP のように先頭が大文字になっていましたよね。データ構築子なので当然です。ところが上の例では、 lamE や varP のように先頭が小文字になり、関数呼び出しになっています。試しに型を見てみましょう。

> :t lamE
lamE :: [PatQ] -> ExpQ -> ExpQ

TH では Q モナド の中で合成を行う都合上、データ構築子の引数や返値の構文木を Q モナド で包んだ形で扱ったほうがべんりなので、こうしたユーティリティ函数が定義されているのです。大抵の構文木の構築子に対してこうした先頭を小文字に直したものが用意されています。また、頻出するイディオムを自動化するための函数も多く定義されています。こうしたものを知っているかいないかでは手間が大きく違うので、リファレンスを一通り見ておくとよいでしょう。

例2：任意長タプルの別解 ── ワイルドカードとデータ構築子

さて、前回は簡単に実装出来てしまいましたが、タプルは単なる 代数的データ型 でした。

(1,2,3) == (,,) 1 2 3
(3,4)   == (,) 3 4

また、変数をタプルの要素数の数だけ生成しましたが、これはいかにも無駄なので、ワイルドカードパタン _ で代用出来そうな気もします。なので、ここでは以下を使った別解を考えてみたいと思います：

1. タプルのデータ構築子に対するパタンマッチ
2. ワイルドカードパタン

ワイルドカードパタンはそのものズパリ、WildP と云うのがそれを表わす構文木です。勿論 Q モナド 版の wildP もあります。これを使えば全然問題ないですね。

ではデータ構築子のパタンマッチはどうすればいいのでしょう？と云う訳でまた GHCi に訊いてみましょー。

> runQ [p| (,,) 1 2 3 |]
ConP GHC.Tuple.(,,) [LitP (IntegerL 1),LitP (IntegerL 2),LitP (IntegerL 3)]
> :t ConP
ConP :: Name -> [Pat] -> Pat

ConP と云うのがその物ズバリのようですね。引数から明らかなように、構築子の名前が第一引数、構築子に対する引数のリストが第二引数になります。

ところで、一つ問題があります。上では3要素決め打ちだったのでデータ構築子の名前は (,,) で大丈夫でしたが、任意長に対してはどうすればいいのでしょう？

mkName ("(" ++ (replicate count ',') ++ ")")

で出来ないこともないですが、いかにもスマートではないですね……。

と、云わけでリファレンスを紐解きましょう。すると、

tupleDataName :: Int -> Name

と云うお誂え向きの函数が見付かります！こんな具合に、 GHCi に頼り切らずリファレンスで何かよいものがないかを探すのは、再三の繰り返しになりますが、とても大事です。基本的な函数やデータ型は Language.Haskell.TH、ユーティリティ函数やシノニムは Language.Haskell.TH.Lib を参照すると良いでしょう。

では、上のものを使って sel を書き直してみたものが次です：

sel' :: Int -> Int -> ExpQ
sel' count nth | count >= nth = do
  var <- newName "x"
  let pats = replicate (nth - 1) wildP ++ [varP var] ++ replicate (count - nth) wildP
  lamE [conP (tupleDataName count) pats] (varE var)

説明はもう殆んど要らないと思います。沢山変数を生成するかわりに目当ての引数と残りをワイルドカードにしたのと、あとは明示的にタプルに対するパタンマッチで書き直したのだけです。

さて、以上の知識を得た上で、次の課題をやってみたいひとはやってみてください。

1. 任意長タプル要素の入れ替え函数を定義する (難易度：易)
2. 一般化 flip の定義。(難易度：易)
3. 一般化 curry/uncurry の定義。(難易度：易) - つまり、 $(ncurry 5) :: ((a,b,c,d,e) -> f) -> a -> b -> c -> d -> e -> f となるような ncurry の定義。uncurryも同様。

インスタンス の自動生成──型情報と定義の扱い

さて。大体コツはつかめてきたでしょうか。タプルの例はちょっと簡単すぎた感があるので、いっきに進んだ例を扱ってみましょう。

ソースコード全てを載せると大変なので、GitHubに載せたソースコードを参照してください。

次のようなバイナリ・エンコードのための型クラス、Bin を考えます(完全な実装は GitHub の Bin.hs をご覧ください)：

data Bit = O | I deriving (Show, Read, Eq, Ord)

class Bin a where
  encode :: a -> [Bit]
  decode :: [Bit] -> (a, [Bit])

instance Bin Int where
  encode = ...
  decode = ...

この Bin のインスタンスを一々生成していたのではとても面倒なので、何とかして自動生成したいなあ、と思いますよね？思ってください⁹。

さて、自動生成したいと思って貰えたと思います。その方法は総称プログラミングの手法をつかったり色々ありますが、ここでは Template Haskell を使おうと思います。TH でそんなことが出来るの？と思うかもしれませんが、TH には

• 型や函数、インスタンスの情報を取得する

と云う最強の技が残っていたのでした。この章の目的は、この機能を説明することです。

型、函数、 クラス の情報を取得するには reify¹⁰ 函数

reify :: Name -> Q Info

を使用します。名前に紐付けられている実体に関する情報 Info を返してくれます。リファレンスを読むとわかるように、2.5.0.0 時点では 型クラス 、型構築子、データ構築子、変数、 型変数 の情報を得ることが出来ます。

なんだかわくわくしますね！早速試してみましょう。

$ ghci -XTemplateHaskell 
GHCi, version 7.0.4: http://www.haskell.org/ghc/  :? for help
> :m Language.Haskell.TH
> runQ $ reify ''String
Template Haskell error: Can't do `reify' in the IO monad
*** Exception: user error (Template Haskell failure)

おや、怒られてしまいましたね……。そう、実は reify函数はコンパイル時にしか実行出来ない んです。

これは、Template Haskell は裏で GHCi を使って色々な処理をしているかららしいです。らしい、と云うのは良くしらないと云うことです。

なので、「この型の情報が欲しいなあ」「この函数の情報が欲しい」「クラス舐めたいぺろぺろ」みたいなことを考えたら、一旦プログラムを書いて、それをGHCiで読み込むなり実行するなりしてやる必要があります。そこで、 reifier.hs とか適当な名前のファイルを作って、そこで色々実験することにしましょう。

{-# LANGUAGE TemplateHaskell #-}
import Language.Haskell.TH
import Bin

do info <- reify ''String
   runIO $ print info
   return []

これを GHCi で読み込むと……

> :l reifier.hs
[1 of 1] Compiling Main             ( reifier.hs, interpreted )
TyConI (TySynD GHC.Base.String [] (AppT ListT (ConT GHC.Types.Char)))
Ok, modules loaded: Main.

シレッと String の定義を盗み見ることに成功しました！真ん中の TyConI のところです。

ところで、上の reifier.hs ですが妙ですね……。何もないところにいきなり do-式が書いてあります。malformed なんじゃないの？

そんなことはありません。実はこれは、

$(do info <- reify ''String
     runIO $ print info
     return [])

の省略形なのです。そういえばだいぶ昔に「トップレベル宣言では $( )を省略出来る」と云うようなことを云っていたと思います。宣言の接合なので do式全体の値は Q Dec を返す必要があります。なので、最後の行で return [] としてツジツマを合わせているのです。

では、さっき定義した Bin 型クラス の情報を見てみたいですね。しかし、Bin の名前はどうやって指定すればいいのでしょう……？

実は、TH では型名と型クラス名は同じ名前空間・構文木で表現されるという約束があります。なので今のプログラムの

do info <- reify ''String

を

do info <- reify ''Bin

に書き換えれば……

> :l reifier.hs
[1 of 2] Compiling Bin              ( Bin.hs, interpreted )
[2 of 2] Compiling Main             ( reifier.hs, interpreted )
ClassI (ClassD [] Bin.Bin [PlainTV a_1627406217] [] [SigD Bin.encode (ForallT [PlainTV a_1627406217] [ClassP Bin.Bin [VarT a_1627406217]] (AppT (AppT ArrowT (VarT a_1627406217)) (AppT ListT (ConT Bin.Bit)))),SigD Bin.decode (ForallT [PlainTV a_1627406217] [ClassP Bin.Bin [VarT a_1627406217]] (AppT (AppT ArrowT (AppT ListT (ConT Bin.Bit))) (AppT (AppT (TupleT 2) (VarT a_1627406217)) (AppT ListT (ConT Bin.Bit)))))]) [ClassInstance {ci_dfun = Bin.$fBinInt, ci_tvs = [], ci_cxt = [], ci_cls = Bin.Bin, ci_tys = [ConT GHC.Types.Int]},ClassInstance {ci_dfun = Bin.$fBinBool, ci_tvs = [], ci_cxt = [], ci_cls = Bin.Bin, ci_tys = [ConT GHC.Bool.Bool]},ClassInstance {ci_dfun = Bin.$fBin[], ci_tvs = [PlainTV a_1627406230], ci_cxt = [ClassP Bin.Bin [VarT a_1627406230]], ci_cls = Bin.Bin, ci_tys = [AppT ListT (VarT a_1627406230)]},ClassInstance {ci_dfun = Bin.$fBinBit, ci_tvs = [], ci_cxt = [], ci_cls = Bin.Bin, ci_tys = [ConT Bin.Bit]}]
Ok, modules loaded: Bin, Main.

うひゃあ、長々とデータご出て来ましたね！メンバ函数の型や制約、 クラス の インスタンス などの情報が取れているのがわかると思います。

ところでリファレンスを見ると、Info 型には

VarI Name Type (Maybe Dec) Fixity

という構築子がありますね。これはきっと函数・変数の定義をとってくる子にちがいありません。 Maybe Dec ということはひょっとすると定義も取ってこれるのかな……！ と思いつつ先程の部分を、

do info <- reify 'curry

にしてみると……

> :reload
[1 of 2] Compiling Bin              ( Bin.hs, interpreted )
[2 of 2] Compiling Main             ( reifier.hs, interpreted )
VarI Data.Tuple.curry (ForallT [PlainTV a_1627409906,PlainTV b_1627409907,PlainTV c_1627409908] [] (AppT (AppT ArrowT (AppT (AppT ArrowT (AppT (AppT (TupleT 2) (VarT a_1627409906)) (VarT b_1627409907))) (VarT c_1627409908))) (AppT (AppT ArrowT (VarT a_1627409906)) (AppT (AppT ArrowT (VarT b_1627409907)) (VarT c_1627409908))))) Nothing (Fixity 9 InfixL)
Ok, modules loaded: Bin, Main.

おお、型の情報とか色々とれた！と思いますが肝心の函数定義のところが Nothing ですね……。

ここで残念なお知らせです。Info には定義を入れる部分があるにもかかわらず、現在 函数定義をとってくる機能は実装されていません。まあ余り使わないと云えばそれまでですが、悲しいものがありますね……。

閑話休題。いよいよインスタンスの自動生成にはいりましょー。まずは常套手段、適当な宣言を書いて構文木の探りを入れてみましょう。

> :{
 runQ [d|
   instance (Bin a) => Bin (Maybe a) where
     encode Nothing = [O]
     encode (Just a) = I : encode a
     decode (I:xs) = let (a, xs') = decode xs in (Just a, xs')
     decode (O:xs) = (Nothing, xs)
   |]
:}
[ InstanceD
    [ClassP Bin.Bin [VarT a_0]]
    (AppT (ConT Bin.Bin) (AppT (ConT Data.Maybe.Maybe) (VarT a_0)))
    [ FunD encode [ Clause [ConP Data.Maybe.Nothing []] (NormalB (ListE [ConE Bin.O])) []
                  , Clause [ConP Data.Maybe.Just [VarP a_1]]
                           (NormalB
                             (InfixE (Just (ConE Bin.I)) (ConE GHC.Types.:) (Just (AppE (VarE encode) (VarE a_1))))) []]
    , FunD decode [ Clause [InfixP (ConP Bin.I []) GHC.Types.: (VarP xs_2)]
                           (NormalB (LetE [ValD (TupP [VarP a_3,VarP xs'_4]) (NormalB (AppE (VarE decode) (VarE xs_2))) []] (TupE [AppE (ConE Data.Maybe.Just) (VarE a_3),VarE xs'_4]))) []
                  , Clause [InfixP (ConP Bin.O []) GHC.Types.: (VarP xs_5)]
                                   (NormalB (TupE [ConE Data.Maybe.Nothing,VarE xs_5])) []]
   ]
]

インスタンス 宣言には InstanceD を使えばよいようですね。構文木の引数の順番は大体実際のプログラムで書く順番に対応しているので、それぞれ順に インスタンス 制約、 インスタンス 宣言本体、メンバ函数などの定義であろうと類推をつけることが出来ます。実際型を見てみると、

> :t InstanceD
InstanceD :: Cxt -> Type -> [Dec] -> Dec

どうやら読み通りだったようです。 Cxt の説明を見ると Pred と云うのが出て来て、 クラス 制約を表わす ClassP と型同値を表わす EqualP の二つがあることがわかります。上で吐かれた構文木だと Bin a と云う制約が掛かっている様によめます。

次に函数定義の方を読んでいきましょう。encode の定義とおぼしき部分だけ切り出すと、

FunD encode [ Clause [ConP Data.Maybe.Nothing []]
                     (NormalB (ListE [ConE Bin.O]))
                     []
            , Clause [ConP Data.Maybe.Just [VarP a_1]]
                     (NormalB
                       (InfixE (Just (ConE Bin.I)) 
                               (ConE GHC.Types.:) 
                               (Just (AppE (VarE encode) (VarE a_1)))))
                     []
            ]

こうなっているので、 FunD の型を見てみます。

FunD :: Name -> [Clause] -> Dec

これは、関数名と定義節(Clause)のリストを取って函数定義の構文木を返すと云うことでしょう。定義節とは、例えば上の例であれば、

encode Nothing = [O]
encode (Just a) = I : encode a

の各行、つまり Nothingに対する場合、Just に対する場合の函数の定義それぞれのことです。 GHCi で Clause の情報を見てみると、

> :info Clause
data Clause = Clause [Pat] Body [Dec]
      -- Defined in Language.Haskell.TH.Syntax
instance Eq Clause -- Defined in Language.Haskell.TH.Syntax
instance Show Clause -- Defined in Language.Haskell.TH.Syntax
instance Ppr Clause -- Defined in Language.Haskell.TH.Ppr

となっています。データ構築子は Clause のみで、引数(のパタン)のリスト、定義の式本体と、いくつかの定義のリストを取るようになっていますね。

最後の定義のリストはなんでしょうか？THの構文木は実際の構文に習って組み立てられていることから類推すると……？実は、これは where 節に取られる定義のリストです。

Haskell を書いていると、時々「あれっ、where 節って関数定義全体にわたるんだっけ……？」と思うときがありますが、この構文木を見れば一目瞭然に各パターンに対してだけであることがわかりますね。 このように、THをやっているとHaskellの構文木でアイマイにしか理解していなかったところを理解できると云う副作用があります。わいわい。

さて、必要な道具は大体そろった気がします。あとは今迄の要領で知らない構文木を調べていけばいいわけです。と、云う訳で一般の インスタンス 導出に移りましょう。

一般的なデータ型をどうやってバイナリにエンコードするか、と云う方法を上の Maybe の例から考えみてましょう。Maybe の場合、

data Maybe a = Nothing | Just a

と云う定義に対して、

1. 一番左の Nothing だったら O だけでおわり
2. 二番目の Just a だったら I に続けて a をエンコードしたものをくっ付ける

と云う感じの定義になっていました。これをより一般の場合に敷衍してみましょう。たとえば次の型を上のマナーの類推でエンコードするとどうなるか？

data WeightTree a = Nil | Leaf Int a | Branch (WeightTree a) (WeightTree a)

1. 一番左の Nil -> [O]
2. その右の Leaf i a -> I + O + i のエンコード + a のエンコード
3. 一番右の Branch t s → I + I + t のエンコード + s のエンコード

こんな感じになりそうです。要は構築子の左から順に、O、IO、IIO、IIIO……と区別のつくようにタグを割り振って、それに続けて引数を順番にエンコードして置いていけばよいわけです。そして、最後のタグについては O を付けると冗長なのでそれをとってしまえばいい、と。

こんな原理に従って encode の自動生成まで書いたのがリポジトリの BinTH.hs です。

そこから核になる部分を取り出してみましょう。

deriveBin :: Name -> Q [Dec]
deriveBin dName = do
  DataD cxts name vars cons _ <- normalizeInfo <$> reify dName
  (cs, pats, exps) <- unzip3 <$> mapM implForCon cons
  let cxts = return $ map (ClassP ''Bin . pure) $ nub $ concat cs
      funs = genFuns pats exps
  return <$> instanceD cxts (appT (conT ''Bin) (appsT $ conT name : map (varT . tvName) vars))
                       [funD 'encode funs]

deriveBin は Bin のインスタンス にしたい型の名前を取ってその定義を返す函数です。reify で型情報を取得して、自前で定義した normalizeInfo でデータ型の定義に変換しています。変換と云うと大袈裟に聴こえますが、基本的に data 定義とnewtype定義以外を弾いて、面倒なので結果は data 定義のものに統一するように処理をしているだけです(詳しくはソース参照)。

次の行では、下で定義されている implForCon 函数にデータ構築子の情報を渡して、各構築子に対するエンコード函数の定義に必要な型制約、引数のパターン、定義本体(のもとになるもの)を取得しています。必要な型制約、と云うのは Maybe a の a や WeightTree a の a などの 型変数 のように、Bin クラス の インスタンス になっていなくては困るものを抜き出してきていると思ってください。

implForCon :: Con -> Q ([Type], PatQ, ExpQ)
implForCon con = do
  let (name, typs) = conTypesAndName con
  vars <- replicateM (length typs) $ newName "x"
  let pats = map varP vars
      exps = map varE vars
      expr = [| concat $(listE $ map (appE [| encode |]) exps) |]
  return (filter isVarType typs, conP name pats, expr)

自前で定義した conTypeAndName で構築子の名前とその引数型のリストを取り出し、引数の数だけパタンマッチに必要な変数名を newName で用意しています。返値タプルは左から順に、引数に含まれている 型変数 のリスト、パタン、エンコードする式です。

そうして得た情報を基に、制約の生成や函数定義部分の生成を行っているのが BinTH.hs の 14, 15行目です。

15行目で呼んでいる genFuns は、パタンのリストと式のリストを取って、各構築子に対するO,Iのタグを付加した定義節を定義する函数です：

genFuns :: [PatQ] -> [ExpQ] -> [ClauseQ]
genFuns []     []     = [ ]
genFuns [p]    [e]    = [ clause [p] (normalB e) []]
genFuns (p:ps) (e:es) =
  clause [p] (normalB $ [| O : $(e) |]) [] : map modifyBody (genFuns ps es)
  where
    modifyBody :: ClauseQ -> ClauseQ
    modifyBody cq = do
      Clause pat (NormalB e) [] <- cq
      clause (map return pat) (normalB [| I : $(return e) |]) []

こうして関数定義節本体を得たら、あとは instanceD で包んで返してあげればよいだけです。第二引数の

appT (conT ''Bin) (appsT $ conT name : map (varT . tvName) vars)

と云うのが少し読みづらいですが、これは型 インスタンス 宣言の部分で、例えば Either に対しては

Bin (Either a b)

の部分にすぎません。呼ばれている appsT と云うのは、このモジュールで勝手に定義した次の便利函数です：

appsT :: [TypeQ] -> TypeQ
appsT [] = error "appsT []"
appsT [x] = x
appsT (x:y:zs) = appsT ( (appT x y) : zs )

つまり、型のリストを取って、それを順に 適用 してった型を返す函数です。正しくないコードですがこんな感じ。

appsT [Either, Int, String] == Either Int String

式の構文木に関しては、Language.Haskell.TH でappsE と云う同様のことをやってくれる便利函数が居るんですが、型に対しては用意されてなかったのでその定義をちょここっとかえて自前で定義してみました。

ここで気付いたと思いますが、パタンでの 適用 と式・型でのそれの構文木は構造が違います。パタンではデータ構築子に引数全てが完全 適用 されていなくてはいけないので

ConP :: Name -> [Pat] -> Pat

と、構築子の構文木に引数が含まれている形でしたが、式と型に関してはデータ構築子の他にも函数に対する 適用 があったり、 部分適用 があったりするので、

ConE :: Name -> Exp
VarE :: Name -> Exp
AppE :: Exp -> Exp -> Exp

のように構築子、函数、 適用 がそれぞれ別れた形になっています。型についても同様です。

さて、駆け足＆省略が多い感じではありましたが、一応これで BinTH.hs の解説は終わりです。説明を省いた部分についても読んでいけばどういうことをしているのか大体わかると思います。

実際にここで定義したマクロを使っているところを見てみましょう。 BinTHTest.hs を見てください。

{-# LANGUAGE TemplateHaskell #-}
import Bin
import BinTH
import Language.Haskell.TH

data Tree a = Nil | Leaf a | Branch (Tree a) (Tree a)
data Unit a = Unit a

data Phantom a = Phantom Int

data Hoge a = Huga [a] | NilHoge

deriveBin ''Tree
deriveBin ''Unit

マクロを使っているのは、最後の二行の部分です。これはトップレベル宣言なので接合作用素が省略されていて、

$(deriveBin ''Tree)
$(deriveBin ''Unit)

の略記法です。ところで、 Tree の宣言を deriveBin の後に持ってきて読み込み直そうとすると、

/Users/hiromi/haskell/advent/2011/BinTHTest.hs:12:11:
    Not in scope: type constructor or class `Tree'
Failed, modules loaded: Bin, BinTH, TupTH.

と怒られます。こんな具合に、TH のマクロを使うには、それに渡す名前がマクロ呼び出しより物理的に前に出て来ている必要があります。

さて。ちょっと、ここで意欲のあるひとのために幾つか課題を挙げておこうと思います¹¹。

1. encode の例にならって decode 函数の自動生成も実装してください。(難易度：ふつう)

2. 実は、上の型インスタンス制約の処理では上手く動かないところがあります。例えば、

   data Tree a = Leaf [a] | Branch (Tree a) (Tree a)

   のような型に対してのインスタンス制約の文脈が正しく指定出来ません。克服するにはどうすればいいでしょう？(難易度：至難¹²)

   1. 方針1：面倒なので型引数を全部要求しちゃう
   2. 方針2：reify でとれる ClassInstance の情報を利用して文脈を正確に指定するようがんばる

3. 必要なインスタンスが定義されていなかった場合自動的にそれも定義する機能を付ける。(難易度：難)

   1. 方針：reify の ClassInstance の情報や isClassInstance 、 classInstances 函数などを使ってみる
      • ただし、2.5.0.0 の classInstances 函数はとても使い辛い

Template Haskell の落とし穴

ここでは、 THをいじっていると遭遇する落とし穴について解説したいと思います。

multi :: Integer -> ExpQ
multi i = [| (i *) |]

> $(multi 2) 3
6
> let a = 2 in $(multi a) 3

<interactive>:1:22:
    GHC stage restriction: `a'
      is used in a top-level splice or annotation,
      and must be imported, not defined locally
    In the first argument of `multi', namely `a'
    In the expression: multi a
    In the expression: $(multi a)

multi :: Name -> ExpQ
multi n = [| ($(varE n) *) |]

> let a = 2 in $(multi 'a) 3
6

multi :: ExpQ
multi = [| \a -> (a *) |]

wtf :: ExpQ
wtf = infixApp (litE (stringL "hello ")) [| (++) |] (conE 'True)

Prelude > :l MyGreatMacro.hs
[1 of 1] Compiling Main             ( MyGreatMacro.hs, interpreted )
Ok, modules loaded: Main.
Main* Prelude> $(wtf)
<interactive>:1:1:
    Couldn't match expected type `[Char]' with actual type `Bool'
    In the second argument of `(++)', namely `True'
    In the expression: ("hello " ++ True)
    In the result of the splice:
      $wtf
    To see what the splice expanded to, use -ddump-splices

"hello" ++ True

BinTHTest.hs:1:1: Splicing declarations
    deriveBin 'Tree
  ======>
    BinTHTest.hs:13:1-16
    instance Bin a[a3GR] => Bin (Tree a[a3GR]) where
        { encode Nil = (O GHC.Types.: concat [])
          encode (Leaf x[a3Hr])
            = (I GHC.Types.: (O GHC.Types.: concat [encode x[a3Hr]]))
          encode (Branch x[a3Hs] x[a3Ht])
            = (I
             GHC.Types.:
               (I GHC.Types.: concat [encode x[a3Hs], encode x[a3Ht]])) }
BinTHTest.hs:1:1: Splicing declarations
    deriveBin 'Unit
  ======>
    BinTHTest.hs:14:1-16
    instance Bin a[a3GQ] => Bin (Unit a[a3GQ]) where
        { encode (Unit x[a3HW]) = concat [encode x[a3HW]] }