明日使える総称関数(2)

この記事はMetaobject Protocol(MOP) Advent Calendar 2013 5日目の記事として書かれました。

前回はビルトインでサポートされているqualifierの使い方を紹介しました。今回は自前のqualifierを作ってみましょう。問題になるのはSagittariusでは基本のqualifier以外のものはエラーになるという部分ですが、そこをMOPを使って何とかしてしまおうという算段です。

注意
前回の続きなのでタイトルは「明日使える総称関数(2)」となっていますが、このレベルだと明日使える保障はありません。また、使いどころを間違えると大変なことになる可能性があります。使用は自己責任でお願いします。

ここでは:collectというqualifierを導入することにしましょう。要求としてこのqualifierが付いたメソッドの戻り値をリストにパックするものとします。また話を簡単にするために、:primaryメソッドの戻り値は捨てられるものとします。では、コードを見てみましょう。

(import (rnrs) (clos user) (clos core) (srfi :1) (srfi :26))
(define-class <collect-qualifier-generic> (<generic>) ())
(define-method compute-applicable-methods ((gf <collect-qualifier-generic>)
                                           args)
  (let* ((methods (generic-methods gf))
         (appends (filter-map (lambda (m)
                                (and (eq? (method-qualifier m) :collect)
                                     m)) methods)))
    (for-each (cut remove-method gf <>) appends)
    (let ((r (call-next-method)))
      (for-each (cut add-method gf <>) appends)
      ;; make method which collects all result of methods which have
      ;; :collect qualifier
      (list (make <method>
              :generic gf
              :specializers (list)
              :lambda-list 'args
              :procedure (lambda (call-next-method . args)
                           ;; discards other result
                           (compute-apply-methods gf r args)
                           (map (lambda (m) 
                                  (compute-apply-methods gf (list m) args))
                                appends)))))))

(define-generic foo :class <collect-qualifier-generic>)
(define-method foo :collect ((a <symbol>)) 'symbol)
(define-method foo :collect (a) 'top)
(define-method foo ((a <symbol>)) (print a) 'b)

(print (foo 'a))
;;> a
;;=>(top symbol)

順番に見ていきましょう。

まず、:collect qualifierをサポートするための総称関数クラスをのサブクラスとして作ります。これにより、MOP用総称関数の一つであるcompute-applicable-methodsの特殊化を可能にします。
次にcompute-applicable-methodsを先ほど作ったクラスで特殊化します。処理の中身は以下のフローです。

1. 総称関数fooに登録されている全てのメソッドから:collect qualifierを持つものを除く
2. 親クラスの処理を呼び出し、戻り値を保存する
3. 取り除いたメソッドを戻す
4. 処理に使われるメソッドを作成する*1

#4で作られたメソッドは以下の処理を行います。

1. 上記#2で作られたメソッドチェインを実行する
2. :collect qualifierの付いたメソッドを全て実行する*2

上記の振る舞いを適用するために

(define-generic foo :class <collect-qualifier-generic>)

のように生成される総称関数のクラスを指定します。

たったこれだけです。Sagittariusではメソッドを作る構文がdefine-methodしかないので、フロー1の#4が多少煩雑な感じがしますが、やっていることは非常に単純です。

MOPとか、オブジェクト構築の振る舞いを変えるとか言われると非常に難しいことをしている気がしますが、たったこれだけで面白いことができるわけですから遊んでみない手はないでしょう。

*1 束縛されないのでspecializerを真面目に指定する必要はありません。
*2 真面目にやるならメソッドのソートや受け取った引数の型を調べてメソッドの選別をする必要がありますが、この例では簡便にするために省いています。