bonotakeの日記

元・ソフトウェア工学系研究者、今・AI系エンジニア

テンプレートモナドを書いてみた

前回のエントリー

Haskellで実際にモナド書きかけたけれど、仕事ほっぽり出して遊んでしまいそうだったので、自重。

こんな事を言ってましたが、週末でちょっと手が空いたのでやってみました。元ネタはココとかココとか。

Haskellの」モナド機構を使わないバージョン(←紛らわしい…)

いきなりHaskellモナドに翻訳しようとすると手こずったので、まずはm-hiyamaさんとこの書き方に割と忠実に、モナド機構を利用しないで書いてみました。

{- 型の定義 -}
type Text = String
data Template a = Templ { runTemplate :: a }

{- テンプレート展開処理 -}
processTemplate :: Template Text -> (Text -> Template Text) -> Template Text
processTemplate (Templ t) con = 
    Templ $ foldl1 (++) $ map (\p -> (fst p) ++ (runTemplate . con $ snd p)) $ splitNames t

{- テンプレートのパージング -}
splitNames :: Text -> [(Text,Text)]
splitNames s =
        case elemIndex '{' s of
            Just n -> case elemIndex '}' s of
                Just m -> (take n s, take (m-n-1) $ drop (n+1) s) : (splitNames $ drop (m+1) s)
                Nothing -> [(take n s, drop n s)]
            Nothing -> [(s, "")]

{- Template Text 型を文字列に見せるためのおまじない -}
instance Show (Template Text) where
    show (Templ t) = show t

processTemplate は多分、オリジナルと同じもの。splitNames は processTemplate の中で使っていて、"あいうえお{かきくけこ}さしすせそ" を構文解析して [("あいうえお", "かきくけこ"), ("さしすせそ", "")] てな感じに構造化します。
あとこっそり(?)、(Template a)型の定義と一緒に定義した runTemplate :: (Template a) → a なる関数も使ってます。

これで動かしてみることは可能。以下はm-hiyamaさんとこにあったサンプルデータを翻訳したもの。

{- テスト用データ -}
message :: Template Text
message = Templ $ "{greeting} {body} -- {sign}"

confun1, confun2 :: Text -> Template Text
confun1 "greeting" = Templ "Hello, {person}."
confun1 "body" = Templ "It's a {good-or-bad} News, ..."
confun1 "sign" = Templ "Hanako"
confun1 s = Templ s

confun2 "person" = Templ "Tonkichi"
confun2 "good-or-bad" = Templ "Good"
confun2 s = Templ s

これで、

*Main> message
"{greeting} {body} -- {sign}"

これが、

*Main> processTemplate (processTemplate message confun1) confun2
"Hello, Tonkichi. It's a Good News, ... -- Hanako"

こうなります。ついでに、

(>>>) :: Template Text -> (Text -> Template Text) -> Template Text
t >>> con = processTemplate t con

processTemplate の言い換えでしかないのですが、こんなのを定義してやると

*Main> message >>> confun1 >>> confun2
"Hello, Tonkichi. It's a Good News, ... -- Hanako"

となりました。お〜モナドっぽい(笑)

モナド機構を使うバージョン

で、これをそのままHaskellモナドに翻訳しようとしたら、どうもうまくいかなかったので*1、少しだけ方針を変更。Template型を

type Text = String
data Template a = T Text | N a | C [Template a]  deriving Show

こんな風に、元から構造化された形式で扱うようにしてみました。(Tの定義を修正しました。) T Text が展開されないテキスト部分、N a がテンプレートの名前(キー)に相当する箇所で、全体はこれらのリスト構造として、C [Template a] という型になるようにしました。んで、モナドの定義。

instance Monad Template where
    return a = N a
    (T t) >>= con = T t
    (N t) >>= con = con t
    (C ts) >>= con = C $ level $ map (\t -> t >>= con) ts

至ってシンプルです。これでいいのだろうか?
だめです。これだと、モナド法則のうち m >>= return == m (ext(unit)(t) = t) が成り立たないですね。うむむ。…後で考えることにして、とりあえず放置。
問題は、return にしても (>>= con)の部分にしても、適用するのは (N t) に対応する部分だけでよくて、(T t) の部分はスルーさせてもいいんだけど、現状そうなってないことのようです。でも、Haskellモナド機構の場合、そういうスルーがうまくいかない(con :: a -> m b なので、con を通過させないと、型が m b となる値が得られず、型エラーを起こす)ような。回避方法はあるのかしらん。

そもそも、テキスト部分の型を (T a) とせず、固定の (T Text) とすれば問題ないことに気づきました。よって、Template型の定義と合わせて、モナドの定義も修正。これで問題ない…はず。

最後の行に出てくるlevelってのは、テンプレート展開したときに C [... , C [...] , ] とリストがネストしてしまうので、それを平坦化する関数です。実際はなくても動くのですが、テンプレートテキスト(「浅くネストしたテキスト」)と、多段にネストしたテキストの区別がつきにくくなるので、敢えて入れてみました。

{- C [Template a] のネストを回避 -}
level [] = []
level tss@(t:ts) =
    case t of
        (C xs) -> xs ++ ts
        otherwise -> t:(level ts)

で、これだけだと不便なので、テンプレートテキストと、構造化したテンプレートとの間の橋渡しをする2つの関数 (parse, resolve) を入れてやります。

{- テキストからテンプレートへ -}
parse :: Text -> Template Text
parse s =
    case length ss of
        0 -> T ""
        1 -> head ss
        otherwise -> (C ss)
    where ss =  parseToList s

parseToList s =
    case elemIndex '{' s of
        Just n -> case elemIndex '}' s of
            Just m -> [T (take n s), N (take (m-n-1) $ drop (n+1) s)] ++ (parseToList $ drop (m+1) s)
            Nothing -> [T (take n s), N (drop n s)]
        Nothing -> [T s]

{- テンプレートからテキストへ -}
resolve :: Template Text -> Text
resolve (T s) = s
resolve (N n) = "{" ++ n ++ "}"
resolve (C ss) = foldl1 (++) (map resolve ss)

なんかこの2つ、随伴くさいので、やっぱりモナドの中に入れてやれないのだろうかとか思ってしまうのですが、まいいや。今度考えます。
あと、サンプルデータを書き直し。上で作った parse 関数のおかげで、元とあんまり定義する手間は変わってません。

{- サンプルデータ -}
message :: Template Text
message = parse "{greeting} {body} -- {sign}"

confun1, confun2 :: Text -> Template Text

confun1 "greeting" = parse "Hello, {person}."
confun1 "body" = parse "It's a {good-or-bad} News, ..."
confun1 "sign" = parse "Hanako"
confun1 s = parse s

confun2 "person" = T "Tonkichi"
confun2 "good-or-bad" = T "Good"
confun2 s = parse s

これで動かしてみます。

*Main> resolve message
"{greeting} {body} -- {sign}"
*Main> resolve $ message >>= confun1
"Hello, {person}. It's a {good-or-bad} News, ... -- Hanako"
*Main> resolve $ message >>= confun1 >>= confun2
"Hello, Tonkichi. It's a Good News, ... -- Hanako"
*Main> resolve $ return "greeting" >>= confun1
"Hello, {person}."

なんか動いてるっぽいです。おお〜(笑)
実は、上でも書いたけど、message >>= return でうまくうごかないです。("{}{greeting}{ }{body}{ -- }{sign}{}" となる。)return の定義を考え直さないと。大丈夫になりました。
do記法というやつを使って、

foo :: Text
foo = resolve $ do
    t1 <- message
    t2 <- confun1 t1
    confun2 t2

こんな関数を書いても、動きます。

*Main> foo
"Hello, Tonkichi. It's a Good News, ... -- Hanako"
おまけ

下記サイトに、Haskell標準のReaderモナドを使った、少し違うテンプレート処理の実装が例で書いてます。型の作り方とか、ここを参考にしました。


※ 続きを書きました→ http://d.hatena.ne.jp/bonotake/20070218/1171785790

*1:自分はHaskellレベル2〜3程度なので、もっと位の高いHaskellerなら何とかしてくれると思わなくもない。

注:bonotakeは、amazon.co.jpを宣伝しリンクすることによってサイトが紹介料を獲得できる手段を提供することを目的に設定されたアフィリエイト宣伝プログラムである、 Amazonアソシエイト・プログラムの参加者です。