続・Template Haskell入門 -- QuasiQuotes編

先にこちらをどうぞ。Template Haskell入門 - think and error

QuasiQuotesで簡単なものを作りましょう。
ここではヒアドキュメントを作ろうと思います。Haskellにはヒアドキュメントがないですから。

参考:

こんさんのあれ:準クォートでもてかわゆるふわメタプログラミング！ - はてな使ったら負けだと思っている deriving Haskell - haskell
TemplateHaskellのあれ

前提:

GHC7.2.1

そもそもTemplateHaskellで何が出来るのか

「既知の情報」と「ルール」をもとにHaskellのコードを生成するわけですね。
Haskellのコードで直接実現出来ないことや、似たようなコードを大量に書きたい時など便利そうです。
例えば可変引数関数(QuasiQuotesの例としてprintfが挙げられていますね)や、タプル関連の汎用関数とか、大量のインスタンス宣言とかでしょうか。

QuasiQuoter

オレオレQuasiQuotesを作るにはQuasiQuoterを定義すればよいです。それだけです。

heredoc = QuasiQuoter { 
          quoteExp = parseExp :: String -> Q Exp
        , quotePat = undefined  :: String -> Q Pat
        , quoteType = undefined :: String -> Q Type
        , quoteDec = undefined  :: String -> Q [Dec]
}

4つのフィールドはTemplate HaskellのOxford Bracketsのe, p, t, dに対応しているようです。
つまり作成したQuasiQuoterをExpressionの箇所に置くとquoteExpが使用され、Patternの箇所に置けばquotePatが使用される...と言った具合ですね。HereDocumentはexpressionとしてしか使わないため、quoteExp以外はundefinedとしておきます。

runQ

Quoteて種類が沢山あるため、調べるのが面倒ですよね。ということで作りたいHaskellコードのQ表現が知りたいときにrunQを使います。

ghci> runQ [d| main = putStrLn "Hello, Haskell!" |]
[ValD (VarP main_21) (NormalB (AppE (VarE System.IO.putStrLn) (LitE (StringL "Hello, Haskell!")))) []]

というのもQはShowのインスタンスではないため、文字列に直に変換出来ないためのようです。
このとき表示される値コンストラクタはVarE, VarPなど、大文字から始まっていますが、実際に使う時は小文字から始まる関数を用います。

{-# LANGUAGE TemplateHaskell, QuasiQuotes #-}
import Language.Haskell.TH

do
    mainQ <- valD (varP $ mkName "main") (normalB (appE (varE 'putStrLn) (litE (stringL "Hello, Haskell!")))) []
    return [mainQ]

トップレベル宣言(Q [Dec])の場合は$()を省略出来るのでした。main関数が無いですが、そのmain関数をTemplate Haskellで生成しているため問題ありません。このまま実行出来ます。
valDはDecQ(Q Decのシノニム)を返すので、Q [Dec]に変換しています。QはFunctorのインスタンスなのでfmap使っても良いですが。

ヒアドキュメント作成

ということでString -> ExpQとなるパーサを書いてあげればよいわけです。
今回はヒアドキュメントなので、ExpQの部分は文字列のQ表現になれば良い訳です。
ということで調べてみると、

ghci> runQ [|"aaa"|]
LitE (StringL "aaa")

こんなかんじですね。
そのためOxford Bracketsの中の文字列をそのまま返すだけであるなら、QuasiQuoterを以下のように設定すればいいわけです。

doNothing :: QuasiQuoter
doNothing = QuasiQuoter { 
          quoteExp = litE . stringL
        , quotePat = undefined 
        , quoteType = undefined 
        , quoteDec = undefined 
}

実行すると以下のようになります。

ghci> [doNothing| aaa bbb |]
" aaa bbb "

できました。しかし折角HereDocumentを作るのなら、変数を文字列として埋め込みたいですね。
antiQuotesは誰でも何となくわかるPHP風としましょう。$var, {$var}とかいった記述です。
アンチクオート置き換え部分は正直まだよくわかってないです。特にdataToExpQが具体的に何しているかわからんです。
とりあえずこんさんのJSONのアレを参考に適当に修正して作りました。

{-# LANGUAGE TemplateHaskell, DeriveDataTypeable, OverlappingInstances, OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
module HereDoc (heredoc) where
-- Template Haskell
import Language.Haskell.TH
import Language.Haskell.TH.Quote
import Data.Generics
-- Parser
import Data.Attoparsec.Text
import Data.Text.Internal (Text)
import qualified Data.Text as T
import Control.Applicative hiding (many)
-- General purpose
import Control.Monad
import Data.Maybe

-- 目的のQuasiQuoter
heredoc :: QuasiQuoter
heredoc = QuasiQuoter { 
          quoteExp = parseExp
        , quotePat = undefined 
        , quoteType = undefined 
        , quoteDec = undefined 
}

data HereDoc = HDString String
             | HDQuote String
             | HDList [HereDoc]  -- うーんスマートじゃない。
    deriving (Show, Eq, Data, Typeable)

--------------------------------------------------------------------------------

hdString = HDString . T.unpack <$> takeWhile1 (notInClass "${")
hdQuote = HDQuote . T.unpack <$> (curlyBraced antiQuoteSymbol <|> antiQuoteSymbol)
-- {,$あたりが含まれていてantiQuoteでは無い部分をHDStringとして消費。あんまりスマートじゃないけど。
notHdQuote = HDString . T.unpack <$> (string "$" <|> string "{")
antiQuoteSymbol = string "$" *> (liftM T.pack $ many1 (letter <|> digit <|> char '_'))
-- attoparsecのこの演算子よいね。
curlyBraced p = "{" .*> p <*. "}"
-- 適当にtryべたべた
parserHereDoc = many (try hdQuote <|> try notHdQuote <|> try hdString)

--------------------------------------------------------------------------------

parseQa :: (HereDoc -> Q a) -> String -> Q a
parseQa heredocToA str = do
    case parseOnly parserHereDoc (T.pack str) of
        Right hd -> heredocToA $ HDList hd
        Left _ -> error "err"

-- 良く分かってない
parseExp :: String -> ExpQ
parseExp = parseQa (dataToExpQ $ const Nothing `extQ` antiQuoteE)

-- 良く分かってない
antiQuoteE :: HereDoc -> Maybe ExpQ
antiQuoteE (HDQuote nm) = Just $ {-appE (varE 'show)-} (varE $ mkName nm)
antiQuoteE (HDString nm) = Just $ litE (stringL nm)
antiQuoteE (HDList hds) = Just $ appE (varE 'concat) (listE $ mapMaybe antiQuoteE hds) -- mapMaybeおかしい

現在antiQuoteとしてStringしか埋め込めません。
Showのインスタンスならshowして埋め込み、とかしたかったのだけど、そうすると肝心のStringをshowした時にダブルクォートが表示されてしまってよくない..
まあうまく処理出来なかったのでそのうち。

ghci> :load HereDoc.hs
ghci> :set -XTemplateHaskell -XQuasiQuotes
ghci> let aaa = "AAA"; bbb = "BBB"; ccc = "CCC"
ghci> [heredoc|{$aaa}hoge$bbb{$ccc}|]
"AAAhogeBBBCCC"
ghci> let name = "ruicc"; lang = "Haskell"
ghci> [heredoc|Hey $name, how are you doing in $lang?|]
"Hey ruicc, how are you doing in Haskell?"

一応問題なくうごいているようですね。