Template Haskell の例

追記: さらに更新(6/23)。
追記: ちょっと更新。

Template Haskell を以下のように進めている。

  • 生成したいボイラープレートの一部を書き下し、コンパイルが通ることを確認する。
  • インデントによるレイアウト規則を使っている場合は、次に行う構文木の調査のために、波括弧とセミコロンで書き直しておく。
  • 生成したいコードを runQ に渡し、構文木を調べる。
  • 出力された構文木の構造を調べる。
  • 出力された構文木をそのまま返す関数を、サンプルとして書く。
  • コンパイルが通ることを確認したら、生成したいボイラープレートを意識しつつ、リファクタリングする。
  • ボイラープレートを無くす。

以下は実例。

  • 生成したいボイラープレートの一部を書き下し、コンパイルが通ることを確認する。
-- 例。この T1 以外に引数が 2つの T2 a b,3つの T3 a b cと多数の類似のコードがあり、TH で生成したい。
instance (Typeable a, Show a) => Tuple (T1 a)
    where 
      heading (T1 (A a _)) = [a]
      amap f (T1 (A a x)) = T1 (A (f a) x)
      tvalue (T1 (A _ x)) = [show x]
      degree _ = 1
      typeNames (T1 (A _ x)) = [typeOf x]
  • インデントによるレイアウト規則を使っている場合は、次に行う構文木の調査のために、波括弧とセミコロンで書き直しておく。
instance (Typeable a, Show a) => Tuple (T1 a) where { heading (T1 (A a _)) = [a] ; amap f (T1 (A a x)) = T1 (A (f a) x); tvalue (T1 (A _ x)) = [show x]; degree _ = 1; typeNames (T1 (A _ x)) = [typeOf x];}
  • 生成したいコードを runQ に渡し、構文木を調べる。この際、コードはオックスフォード角括弧と呼ばれるカッコで囲む。必要なコードの種別に応じたカッコを用いる必要があり、今回の場合はトップレベルの宣言なので d を使う。構文木は Q [Dec] 型となる。
>>> :t [d| instance (Typeable a, Show a) => Tuple (T1 a) where { heading (T1 (A a _)) = [a] ; amap f (T1 (A a x)) = T1 (A (f a) x); tvalue (T1 (A _ x)) = [show x]; degree _ = 1; typeNames (T1 (A _ x)) = [typeOf x];} |]
[d| instance (Typeable a, Show a) => Tuple (T1 a) where { heading (T1 (A a _)) = [a] ; amap f (T1 (A a x)) = T1 (A (f a) x); tvalue (T1 (A _ x)) = [show x]; degree _ = 1; typeNames (T1 (A _ x)) = [typeOf x];} |]
  :: Q [Dec]

>>> runQ [d| instance (Typeable a, Show a) => Tuple (T1 a) where { heading (T1 (A a _)) = [a] ; amap f (T1 (A a x)) = T1 (A (f a) x); tvalue (T1 (A _ x)) = [show x]; degree _ = 1; typeNames (T1 (A _ x)) = [typeOf x];} |]
[InstanceD [ClassP Data.Typeable.Typeable [VarT a_0],ClassP GHC.Show.Show [VarT a_0]] (AppT (ConT RT.Tuple) (AppT (ConT RT.T1) (VarT a_0))) [FunD heading [Clause [ConP RT.T1 [ConP TH.A [VarP a_1,WildP]]] (NormalB (ListE [VarE a_1])) []],FunD amap [Clause [VarP f_2,ConP RT.T1 [ConP TH.A [VarP a_3,VarP x_4]]] (NormalB (AppE (ConE RT.T1) (AppE (AppE (ConE TH.A) (AppE (VarE f_2) (VarE a_3))) (VarE x_4)))) []],FunD tvalue [Clause [ConP RT.T1 [ConP TH.A [WildP,VarP x_5]]] (NormalB (ListE [AppE (VarE GHC.Show.show) (VarE x_5)])) []],FunD degree [Clause [WildP] (NormalB (LitE (IntegerL 1))) []],FunD typeNames [Clause [ConP RT.T1 [ConP TH.A [WildP,VarP x_6]]] (NormalB (ListE [AppE (VarE Data.Typeable.typeOf) (VarE x_6)])) []]]]
  • 出力された構文木をそのまま返す関数(ここでは仮に defT1Ex :: Q [Dec]とする)を、サンプルとして書く。GHC の制限で、トップレベルの宣言は import されなければならないので、構文木を返す関数は、利用するファイルとは別のファイルに書いておく。また、構文木に以下の修正を行なう。
    • a_0 や a_1, f_1 などの名前は mkName で作った Name データにおきかえる。※変数名のキャプチャに注意。newName を使う方法がより正しい。
    • ライブラリ関数や型名も mkName で作った Name データにおきかえる。ただし、mkName "GHC.Show.Show" ではうまくいかない。 mkName "Show" とする。
-- コード生成を定義しているファイル x.hs
defT1Ex :: Q [Dec]
defT1Ex = return defT1Ex'
defT1Ex' =
    [InstanceD
     [ClassP typeable [VarT a_0], ClassP showClass [VarT a_0]] -- Cxt
     (AppT (ConT tuple) (AppT (ConT t1) (VarT a_0))) -- Type
     [
      FunD (mkName "heading") [Clause [ConP t1 [ConP conA [VarP a_1, WildP]]] (NormalB (ListE [VarE a_1])) []],
      FunD (mkName "amap") [Clause [VarP f_2,ConP t1 [ConP conA [VarP a_3,VarP x_4]]] (NormalB (AppE (ConE t1) (AppE (AppE (ConE conA) (AppE (VarE f_2) (VarE a_3))) (VarE x_4)))) []],
      FunD (mkName "tvalue") [Clause [ConP t1 [ConP conA [WildP,VarP x_5]]] (NormalB (ListE [AppE (VarE showFunc) (VarE x_5)])) []],
      FunD (mkName "degree") [Clause [WildP] (NormalB (LitE (IntegerL 1))) []],
      FunD (mkName "typeNames") [Clause [ConP t1 [ConP conA [WildP,VarP x_6]]] (NormalB (ListE [AppE (VarE typeof) (VarE x_6)])) []]]
    ]
    where
      conA = mkName "A"
      showClass = mkName "Show"
      showFunc = mkName "show"
      typeable = mkName "Data.Typeable.Typeable"
      typeof = mkName "Data.Typeable.typeOf"
      tuple = mkName "Tuple"
      t1 = mkName "T1"
      a_0 = mkName "a_0"
      a_1 = mkName "a_1"
      a_2 = mkName "a_2"
      a_3 = mkName "a_3"
      f_1 = mkName "f_1"
      f_2 = mkName "f_2"
      x_4 = mkName "x_4"
      x_5 = mkName "x_5"
      x_6 = mkName "x_6"


-- コード生成を利用するファイル y.hs
...
$(defT1Ex)
-- トップレベル宣言は $() は省略可能で、 defT1Ex と書いてもよい。
...
    • ppr 関数を使うと、展開形を出力できるので適宜用いて確認する。
>>> ppr defT1Ex'
instance (Data.Typeable.Typeable a_0, Show a_0) => Tuple (T1 a_0)
    where heading (T1 (A a_1 _)) = [a_1]
          amap f_2 (T1 (A a_3 x_4)) = T1 (A (f_2 a_3) x_4)
          tvalue (T1 (A _ x_5)) = [show x_5]
          degree _ = 1
          typeNames (T1 (A _ x_6)) = [Data.Typeable.typeOf x_6]
    • ppr 関数は Q モナドに対してはそのままは使えない。runQ で実行したのち pprint する関数 expand を作っておくと簡単に展開形を確認できる。
expand x = runQ x >>= putStrLn . pprint
  • コンパイルが通ることを確認したら、生成したいボイラープレートを意識しつつ、リファクタリングする。どう生成したらいいか不明な場合は、サンプルを増やして確認する。複雑な構文木を作る場合は、単純化するために別の関数として切り出すと間違えにくい。
    • リファクタリング時には等価な、より生成しやすい単純な式に変形することを考える。
      • 引数が一つより多い場合の関数適用、たとえば f x0 x1 x2 は (((f x0) x1) x2) である。foldl を使うと簡単に作成できる。
>>> runQ [d| f x0 x1 x2 = (((f x0) x1) x2) |]
[FunD f [Clause [VarP x0_9,VarP x1_10,VarP x2_11] (NormalB (AppE (AppE (AppE (VarE f) (VarE x0_9)) (VarE x1_10)) (VarE x2_11))) []]]

>>> FunD (mkName "f") [Clause (map (\x -> VarP (mkName ("a" ++ show x))) [1..3]) (NormalB (foldl AppE (VarE (mkName "f")) (map (\x -> VarE (mkName ("a" ++ show x))) [1..3]))) []]
FunD f [Clause [VarP a1,VarP a2,VarP a3] (NormalB (AppE (AppE (AppE (VarE f) (VarE a1)) (VarE a2)) (VarE a3))) []]
>>> ppr it
f a1 a2 a3 = f a1 a2 a3
    • where 句を使うことで単純にできる場合がある。
  • ghci にオプション -ddump-splices を付けると、splice 時に展開結果を出力してくれる。
  • ボイラープレートを無くす。

ボイラープレートを生成する関数としてまとめ、不要となったボイラープレートを削除する。

参考資料