それでもLispを使う - 2013年を振り返って

今年も残すところわずかになった。ここで一度一年を振り返ることにする。表題*1で謳っているLispとはSchemeのことである。SchemeがLispであるか否かという疑問については一切触れない。

Lispは万能ではない
プログラマであれば誰しも「Lispは神の言語」であるというジョークをしばしば目にすることがあるだろう。もしLispが神の言語であれば、それは万能のツールとなり多くのプログラマが救いを求めて使用しているだろうが、現実はそれとは大きく異なる。人工知能と深いかかわりがある、LispでLispを書いて実行することができる、そういった歴史的または稀有な言語の特徴を指して人が神の言語と呼ぶのであればそうなのかもしれない、しかし、現実の問題を解く際の最適解に常になり得るかといえばそんなことはない。どちらかといえばLispはLispが得意とする分野が限定的であるとさえいえる。

Lispは悟りを開くためのものでもない
Eric Raymondは「How To Become A Hacker」で次のように述べている；

LISP is worth learning for a different reason — the profound enlightenment experience you will have when you finally get it. That experience will make you a better programmer for the rest of your days, even if you never actually use LISP itself a lot.

しかしながら、Lispを使い始めて4年になるが悟りといったものを開けたと思ったことは一度たりともない。むしろ使えば使うほどに目の前に聳え立つ大きな壁のようなものがLispの限界を知らしめてくる、そんな気にさえなる。全く異なるパラダイムの言語を複数習得する過程で悟りが開けるのかもしれないが、それであればCとC++を学べば悟りを開けることになる。

プログラマは強力な言語を使うべきである
現実の問題は数学のそれとは違い公式があるわけではない*2。正しい答えというものも存在しないかもしれない。その際に使うツールは思考の疎外をしない柔軟でかつあらゆる局面に対して対応可能なものであるべきだ。プログラミング言語はそれぞれに得意とする分野があり、銀の弾などありはしない。であれば、最も手になじむものを複数個選び局面に合わせて使い分ける他に最適な手はないだろう。
私自身の問としては、Lispはどうか？ではなく、Sagittariusはどうか？にならざるを得ない。この一年で果たしてて最も手になじむツールになりえただろうか？答えはYesでもありNoでもある。Sagittariusはこの一年で大きく向上した。ライブラリも充実し、現実の問題に立ち向かえる程度には手になじむようになった。だがここはまだゴールではない。時としてそれがもつ制約や利便性の欠如によって思考が疎外されることがある。いかなる時でも最適解でありえるというのがゴールであれば、ゴールなどありはしないのかもしれない。

一年は長いようで短く、短いようで長い。Sagittariusが今年の初めにどのような姿をしていたのか思い出せない。来年もこの感じがまた味わえるような一年にするとしよう。

*1Lisp AC用に考えていた題ともいうｗ
*2ここでは高校数学を対象としている。

change-class

MOP ACに参加してしまったのでMOPサポートを手厚くしたいなぁという欲求が勝手に高まってきている。サポートしていない機能のもっとも大きなものとしてchange-classとクラスの再定義がある。個人的にどちらもあまり(サポートしてないのだから当然だが)使わない機能で今一どういうものかよく分かっていない。とりあえず、オリジナルのAMOPを当たってみることにした。

AMOPで使われているソースはclossette.lispと呼ばれるものらしく、ググって見るとまぁ簡単に見つかった。これとか。

っで、とりあえず、change-classの骸骨だけ作ってみたのが以下。

(import (rnrs) (clos user) (clos core)
        (sagittarius)
        (sagittarius control))

(define (slot-exists? obj slot)
  (slot-exists-using-class? (class-of obj) obj slot))

(define-method slot-exists-using-class? (class obj slot)
  (not (not (assq slot (class-slots class)))))

(define-method change-class ((old <object>) (new-class <class>) :rest initargs)
  (let ((new (allocate-instance new-class initargs)))
    (dolist (slot-name (map slot-definition-name (class-slots new-class)))
      (when (and (slot-exists? old slot-name)
                 (slot-bound? old slot-name))
        (slot-set! new slot-name (slot-ref old slot-name))))
    ;; TODO
    ;;(%swap-slots new old)
    ;;(%swap-class new old)
    (apply update-instance-for-different-class new old initargs)
    old))

(define-method update-instance-for-different-class
  ((old <object>) (new <object>) :rest initargs)
  (let ((added-slots (remove (lambda (slot-name)
                               (slot-exists? old slot-name))
                             (map slot-definition-name 
                                  (class-slots (class-of new))))))
    (apply shared-initialize new added-slots initargs)))

(define-method shared-initialize ((instance <object>) slot-names :rest all-keys)
  (dolist (slot (class-slots (class-of instance)))
    (let ((slot-name (slot-definition-name slot))
          (init-key   (slot-definition-option slot :init-keyword #f))
          (init-value (slot-definition-option slot :init-value #f))
          (init-thunk (slot-definition-option slot :init-thunk #f)))
      ;; init-keyword is the strongest
      (cond ((and init-key (get-keyword init-key all-keys #f))
             => (lambda (v) (slot-set! instance slot-name v)))
            ((and init-value (get-keyword init-value all-keys #f))
             => (lambda (v) (slot-set! instance slot-name v)))
            ((and init-thunk (get-keyword init-thunk all-keys #f))
             => (lambda (v) (slot-set! instance slot-name (v)))))))
  instance)

ほぼオリジナルのコピー。違いはオリジナルはrotatefでスロットとクラスも変更できるがSagittariusではそんなことできないので本体に何かしら手を入れる必要があるといった点と、shared-initializeが美しくない点か。(普通にinitialize呼び出せばいいじゃん、と思ったのだが、そうすると引数チェックとかがユーザーによって定義されていると嬉しくないのだろう。実際多分嬉しくない)

っで多分以下のように使える(予定)。

(define-class <member> ()
  ((name       :init-keyword :name)
   (occupation :init-keyword :occupation)))

(define-class <member2> ()
  ((first-name :init-keyword :first-name)
   (last-name  :init-keyword :last-name)
   (occupation :init-keyword :occupation)
   ))

(define m (make <member> :name "Takashi" :occupation "Programmer"))

(change-class m <member2> :last-name "Kato" :first-name "Takashi")

CLHSのchange-classにある例では明示的に呼んでいるのでこうあるべきなのだろう。

closseteではクラスの再定義は禁止してるみたいなんだけど、CL、Gaucheともに同名のクラスが既にあった場合クラスの再定義プロセスが走るみたいだが、これどうしたものかな。

XSDを扱いたい

仕事柄SOAPを頻繁に使う。現状ではSOAP-UIを使ってリクエストを投げているのだが、これがまどろっこしくなってきた。SchemeにはSXMLがあるので気合を入れれば何とでもなるのだが(大抵のことは気合を入れれば何とかなるが・・・)、せっかくなので何かしらフレームワーク的なものがあってもいいのではと思ってきた。

0.4.12から入った(binary data)ライブラリの便利さに驚いているので、同様な感じで定義一発でmarshalとunmarshalも可能になるといいかなぁと思っている。例えばこんな感じで定義して

;; Pseudo code
(define-define-xml-schema define-xml-type reader writer)
(define-xml-type <customer> ()
  ((name :type xs:string :element Name :min 1 :max 1)
   (birth-of-country :type xs:string :element BirthOfCountry :min 0 :max 1))
  :namespace "http://example.com"
  :element Customer)

こんな感じで使えるとか

(let ((x (call-with-input-file "sample.xml" reader))
  (writer x (current-output-port)))
#|
<Customer xmlns="http://example.com">
  <Name>read from sample.xml</Name>
</Customer>
|#

ぱっと思いついた感が強いな。

っで、この定義も手で書くのはあほらしいので、XSDをパースして適当に自動生成されるとうれしい気がする。(実際Githubに上げてるSOAPライブラリはその辺が面倒であまり使ってなかったりする・・・)

もう少し案を練ってから実装してみるか。

Sagittarius Scheme 0.4.12リリース

Sagittarius Scheme 0.4.12がリリースされました。今回のリリースはメンテナンスリリースです。

修正された不具合

• CLOSのメソッドを使用したマクロを定義するマクロがエラーになる不具合が修正されました
• bytevector->integerが負の整数に対して正しい値を返さない不具合が修正されました
• mod-inverseがランダムで正しい値を返さない不具合が修正されました
• Windows上でgetenvが正しく値を返さない不具合が修正されました
• get-output-bytevector及びextract-output-bytevectorがSEGVを起こす不具合が修正されました
• R6RSモードでエスケープされたシンボルを読み込むと&lexicalが投げられる不具合が修正されました
• CBCモードで作成された暗号器が初回以降の暗号/復号で正しいIVを使用しない不具合が修正されました
• (rfc mime)がマルチパートデータを正しく処理しない不具合が修正されました

改善点

• cipher-block-sizeが暗号器の名前でも使用可能になりました
• next-method?がメソッド内で使用可能になりました
• is-prime?が巨大数に対してLucas-Lehmer法を使用するようになりました
• スタックトレースが継続をまたいでも表示されるようになりました
• access-protected-resourceでマルチパートデータが使用可能になりました
• inflating-input-portが実際に使用したバイト数のみ元ポートの位置を進めるようになりました
• mime-compose-message-stringがバイナリデータを扱えるようになりました
• open-bytevector-output-portのextraction手続きがtranscoded-portで元ポートが閉じられた後でも使用可能になりました

新たに追加された機能

•  socket-recv!が追加されました
• (binary data)ライブラリが追加されました
• DSAの署名及び検証機能が追加されました
• bytevector->sinteger及びbytevector->uintegerが追加されました
• sinteger->bytevector及びuinteger->bytevectorが追加されました
• (rfc ssh)が追加されました(ドキュメントはまだありません)
• compute-getter-n-setterが追加されました
• slot-ref-using-class、slot-set-using-class!及びslot-bound-using-class?が追加されました

非互換な変更

• nullライブラリが廃止されました

Edge case?

I've just found an interesting behaviour of R6RS implementation about bytevector output port. First of all, look at this piece of code;

(import (rnrs))

(let*-values (((port extract) (open-bytevector-output-port))
              ((out) (transcoded-port port (native-transcoder))))
  (put-string out "hello")
  (display (extract)))

What do you think the (extract) should do? According to the R6RS spec of transcoded-port the port must be closed by special way so that other string operations can be done.

As a side effect, however, transcoded-port closes binary-port in a special way that allows the new textual port to continue to use the byte source or sink represented by binary-port, even though binary-port itself is closed and cannot be used by the input and output operations described in this chapter.
-- R6RS Standard libraries 8.2.6 Input and output ports

I know open-bytevector-output-port can take a transcoder as its optional argument, however I think there is needs that the created bytevector output port needs to be converted later for some reason or user wants to store first pure binary data then some text data.

Now I've tried what the implementations would return, the result was rather interesting. Followings are the tested implementations and its result;

[Implementations that raised an error]

• Larceny 0.97
• Racket 5.2.1
• Sagittarius 0.4.11
• Ypsilon 0.9.6-update3

[Implementations that returned a bytevector]

• Mosh 0.2.7
• Petite Chez Scheme 8.4

The majority is raising an error, but interestingly Chez Scheme which I think the reference implementation of R6RS returned a value. For me, it is convenient the latter behaviour and the specification (as far as I searched) doesn't specify how it should be. The above quotation is only specifying the input/output operation not extracting.

Hmmmm, what should I do?

Mooseのaugment/innerをMOPで

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

PerlにはMooseというMOPをサポートしたオブジェクト指向モジュールがあります*1。その中にaugment/innerという一風変わったメソッドモディファイアがあったのでこれをMOPで実現してみようと思います。

実装するためにはそれがいったいどのように動作するのかを知る必要があります。PerldocのMoose::Manual::MethodModifiersにaugment/innerの項目があるのでそちらを見てみましょう。

…

見ましたね？どうやら動作の肝はinner手続きが下位の実装を呼び出す点にありそうです。これは通常のMOPで実現されるメソッドチェインとは逆です。以下の図は通常とaugment/innerが要求するメソッドチェインを表したものです。

* as-xml is the method
* income-and-expenses is too long so now combined :)
+-------------------+                       +-----------------+                       +-------------------+
| as-xml (combined) | - call-next-method -> | as-xml (report) | - call-next-method -> | as-xml (document) |
+-------------------+                       +-----------------+                       +-------------------+

+-------------------+            +-----------------+            +-------------------+
| as-xml (document) | - inner -> | as-xml (report) | - inner -> | as-xml (combined) |
+-------------------+            +-----------------+            +-------------------+

既に答えは見えている気がしますが、肝はcompute-applicable-methodsです。以下が今回の肝になるコード片です。

(import (rnrs) (clos user) (clos core) (srfi :39))

(define-class <augment-generic> (<generic>) ())

(define *default-inner-value* (make-parameter ""))

(define-method compute-applicable-methods ((gf <augment-generic>) args)
  `(,@(reverse! (call-next-method))
    ;; add very bottom one
    ,(make-method (list <top>)
                  (lambda (call-next-method o) (*default-inner-value*)))))

5日目の記事では与えられたメソッドから特定のqualifierを取り除いて等の複雑なことをしましたが、今回は単に逆順にするだけです。最後にデフォルトの値を返すメソッドを追加しているのがトリックです。Gaucheの<bottom>のようなクラスがあればこのトリックは要らないのですが、*2Sagittariusではサポートしていないので明示的に追加してやる必要があります。

さて肝はできたので後はお化粧です。 このままではinnerをcall-next-methodとして呼ばなければならないのであまりaugment/innerっぽくありません。そこで以下のようにマクロを定義します。

(define-syntax define-augment
  (syntax-rules ()
    ((_ name)
     (define-generic name :class <augment-generic>))))

(define-syntax augment
  (lambda (x)
    (define (analyse args)
      (let loop ((ss args) (rs '()))
        (cond ((null? ss)          (values (reverse! rs) '() #f))
              ((not (pair? ss))    (values (reverse! rs) ss #f))
              ((keyword? (car ss)) (values (reverse! rs) (gensym) ss))
              (else (loop (cdr ss) (cons (car ss) rs))))))
    (define (build k generic qargs rest opts body)
      (define (parse-specializer s)
        (syntax-case s (eqv?)
          ((_ class) (identifier? #'class) #'class)
          ((_ (eqv? v)) #'(eql v))
          ((_ v) #'v)
          (_ #'<top>)))
      (define (->s d) (datum->syntax k d))
      (with-syntax (((specializers ...) (->s (map parse-specializer qargs)))
                    ((reqargs ...)
                     (->s (map (lambda (s) (if (pair? s) (car s) s)) qargs)))
                    (rest       (->s rest))
                    (option     (->s opts))
                    ((body ...) (->s body))
                    (generic    (->s generic))
                    (inner      (->s 'inner)))
        (with-syntax ((real-body (if opts
                                     #'(lambda (inner reqargs ... . rest)
                                         (apply (lambda option body ...) rest))
                                     #'(lambda (inner reqargs ... . rest)
                                         body ...))))
          #'(begin
              (add-method generic
                          (make-method
                           (list specializers ...)
                           real-body))
              generic))))
    (syntax-case x ()
      ((k ?generic ?args . ?body)
       (let-values (((qargs rest opt) (analyse #'?args)))
         (build #'k #'?generic qargs rest opt #'?body))))))

実際に使うには以下のようにします。

(define-class <document> () ())
(define-class <report>  (<document>) ())
(define-class <combine> (<report>) ())

(define-augment xml)
(augment xml ((o <document>))
  (string-append "<doc>" (inner) "</doc>"))

(augment xml ((o <report>))
  (string-append "<title>foo</title>"
                 "<summary>bar</summary>" 
                 "<body>"
                 (inner)
                 "</body>"))
(augment xml ((o <combine>)) "hello")

(xml (make <document>))
;; => <doc></doc>

(xml (make <report>))
;; => <doc><title>foo</title><summary>bar</summary><body></body></doc>

(xml (make <combine>))
;; => <doc><title>foo</title><summary>bar</summary><body>hello</body></doc>

上記のコードの動作には今週末にリリースされる予定の0.4.12が必要なので注意してください*3。ちゃんと下位実装の値がinner呼び出しの部分に埋め込まれているのが確認できます。

MOPを使えば一見処理系でサポートしないといけないような処理でもお手軽にサポートできる可能性を示せていれば幸いです。

*1実際に使ったことはないですｗ
*2どうやら予定通りには動かないようです。勘違いでした。参照
*3make-methodを使わなければ0.4.11でも動作するはず。

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

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

MOPはメタクラス上に構築されます。今回はそのクラスそのものを使って総称関数を使ってみます*1。

MOP ACのこれまでの記事を読まれた方なら既にご存知かと思いますが、 まずはメタクラスとはのおさらいです。MOPをMOP足らしめる大きな存在の一つとしてメタクラスがあります。例えばJavaであれば全てのクラスはjava.lang.Classのサブクラスになるといったように、CLOSでも大元のクラスがあります。CLならばstandard-class、Gauche及びSagittarius*2ならば<class>がデフォルトでクラスのメタクラスになります。ここでデフォルトでと言ったのは(CLOSベースの)MOPではこの階層を変更することができるからです。図で表すと以下のようになります。

+---------+            +-------+        +-----------------+
| <class> | <--------- | <top> | <<-+-- | builtin classes |
+----+----+            +-------+    |   +-----------------+
     ^                              |
     ^                              |   +----------+       +---------------+
     |                              +-- | <object> | <<+-- | <user-class1> |
     |                                  +----+-----+   |   +---------------+
     |                                       ^         |
     |                                       ^         |   +---------------+
     |                                       |         +-- | <user-class2> |
     |                          +------------+             +---------------+
     |                          |
+----+--------+       +---------+----------+
| <metaclass> | <---- | <meta-user-class1> |
+-------------+       +--------------------+

ASCII記号の関係上^及び<をインスタンス作成時に使用されるクラス、縦に並んだ^及び<<を継承関係として使っています。この図では<class>は独立した位置にありますが、実際のCLOSでは<object>のサブクラスになっています。つまり、CLOSのMOPにおいてはメタクラスも単なるオブジェクトに過ぎないということです。しかし、ここでは図を簡略にするため独立したものとして描いています。

CLOSではこのメタクラスのサブクラスを使ってオブジェクト構築の振る舞いをユーザがコントロールできるようにしています*3*4。

ではこれが「明日使える総称関数」とどう関係してくるのでしょうか？ここでは実際に使われている例を見ながらその便利さを体感していきます。拙作Sagittarius Schemeでは最近(binary data)というライブラリが追加されました*5。このライブラリではメタクラスを使用したバイナリデータの読み書きとCLOSでの抽象化を行っています。

実際のコードはユーザの負担を減らすためにマクロでコードの自動生成をしていますが、肝になる部分は以下です。ここではユーザが<；sample>という複合データクラスを:parent-metaclassキーワード引数に<sample-meta-parent>を指定したとします。*1*6

;; This meta class will be generated automatically
(define-class <sample-meta> (<sample-meta-parent>) ())

;; main class
;; suppose user didn't specify the parent class
(define-class <sample> ()
  ((a :init-keyword :a :init-value #f))
  :metaclass <sample-meta>)

;; binary reader
(define-method sample-read ((t <sample-meta>) in . ignore)
　　(let ((o (make t)) ;; !!! POINT !!!
    ;; read structured binary data and set it to the slot(s)
    o))

sample-readはdefine-composite-data-defineマクロに渡されたreaderパラメタです。実際にはマクロによって暗黙的に定義されるので、<sample-meta>はユーザに見えることはありません。

sample-readがこのように定義されてうれしい理由はなんでしょうか？一つの答えとして以下のように書くことができます。

(sample-read <sample> binary-input-port)
;; => instance of <sample>

コードの中でPOINTと書かれている部分がまさに肝です。CLOSではオブジェクトの構築はMOPを使っていると書きましたが、makeも例に漏れず総称関数を<class>で特殊化したものです。つまり、<class>を継承したクラスを渡してやればそのインスタンスを作ることができます。また、総称関数の引数型に指定すればそのクラスで特殊化することが可能です。

このライブラリの例では、バイナリという低レベルの操作をメタクラスによる総称関数のメソッドディスパッチでCLOSのインスタンスにマッピングするため、データの抽象度及びコードの可読性が格段にあがります*7。

今回紹介した例はCLやGaucheと他のCLOSベースのMOPでも応用可能です。贔屓の処理系で実際に動かしてみて理解を深めてみてはいかがでしょうか？

*1この記事が書かれた経緯。
*2Tiny CLOSベースなら恐らくどの処理系でも
*3参考例：Metaobjectでオブジェクト指向プログラミング
*4参考例：コンポジションに便利なpropagatedスロット
*5記事のサンプルコードと現在の実装では仕様が違うので注意
*6大したものじゃないって言ったじゃないですかｗ
*7体感には個人差があります。単なる宣伝です。

Windowsは悪なのか？

多くのハッカーと呼ばれる人、それを目指す人、はたまた凄腕ITエンジニアはWindowsではなくLinuxもしくはUNIXライクOSを使っているし、Windowsを良しとはしない傾向になる。How To Become A HackerでEric Raymondは以下のようにその理由を述べている。

Yes, there are other operating systems in the world besides Unix. But they're distributed in binary — you can't read the code, and you can't modify it. Trying to learn to hack on a Microsoft Windows machine or under any other closed-source system is like trying to learn to dance while wearing a body cast.

確かにそのとおりだ。WindowsはプロプライエタリなOSでそのソースを読むには莫大な金額のライセンス料をMicrosoftに支払ってソースコードを入手する以外にはない。では、LinuxやBSD系UNIXを使っている人たちはそのOSのコードを読むためにそれらを使っているのだろうか？いざというときソースを解析して問題を回避するのだろうか？

そのような統計を見たことはないので憶測でしかないのだが答えはNoではないだろうか？仮に多くの非Windowsユーザーがカーネルのソースコードを読むことはないとしたら、いったい何が彼らをそのOSを使うように仕向けたのだろう？

Windowsは良くも悪くも万人向けである。システムの根幹にかかわる部分に直接手を入れる手段はほぼない。全ての操作はGUIを使って行われる前提で設計されている。万人向けであるがゆえにプログラミングに関係するツールは初期状態では付随していなし、そのシェルはあまりにも貧弱だ。逆にUNIXライクOSでは全ての設定は単にファイルであることが多い。また、プログラマが必要とするツールの多くは初期状態で使用可能であることが多い。さらにOSのシステムコールはWindowsのそれに比べてはるかに簡潔であり、manでそれらの使い方を容易く調べることが可能である。

これだけ比べるとプログラマとしてはWindowsではない方が楽なのではないだろうか？ 既にある開発環境、整備されたドキュメント、簡潔なAPIどれを見てもWindowsにはない。彼らはWindowsから逃げたのではないだろうか？

それは悪いことではない。僕自身Windowsでの開発はCygwin上で行っている。可能な限り楽をしたいからだ。だが、SagittariusはWindowsでの動作も常に確認している。楽をしたいからだ。そして、僕以外の誰かが同じように楽ができることを願っているからだ。OSのインストールは楽ではない。また、量販店で買うコンピュータには基本Windowsが入っている。Windowsを諦めるということは楽ではない作業をしなければならないということだ。僕は心が弱い。目の前に高い壁と通り抜けられそうな茨の道があれば後者を選ぶ。楽がしたいからだ。

Windowsを諦めない*1。

*1これが言いたかっただけｗ

明日使える総称関数(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 真面目にやるならメソッドのソートや受け取った引数の型を調べてメソッドの選別をする必要がありますが、この例では簡便にするために省いています。

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

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

実は今日が誕生日の筆者です。適当に何かを送りつけてくれたり、お祝いの言葉をもらえたりすると喜ぶかもしれません。

さて、MOPと言えばCLOSがまず浮かぶのではないでしょうか。Metaobject Protocolなのでオブジェクトのクラス定義の方をさすのかもしれないのですが、CLOSといえば総称関数が便利です。そこで今回は「明日使える総称関数」と題しまして、qualifierを便利に使いつつMOP的にも満足いくようにしてみたいと思います。

とりあえず前提としてコードは拙作Sagittarius Scheme(0.4.11)で動作確認しています。またGaucheはメソッドのqualifierをサポートしていないので移植は(現状では)不可能ですが、本稿で紹介するqualifierはCLにも同様のものがあるので、そちらへの移植は難しくないかと思います。

まずはメソッドqualifierのおさらいをしましょう。Sagittariusではデフォルトで:primary, :before, :afterそして:aroundの4つのqualifierを実装しています。特に何も指定しない場合は:primaryが暗黙のうちに使用されます。イメージをつかむために簡単な例を見てみます。

(import (rnrs) (clos user))
(define-method print :around args
  (display "around:before") (newline)
  (call-next-method)
  (display "around:after") (newline))

(define-method print :before args
  (display ":before") (display args) (newline))
(define-method print :after args
  (display ":after") (display args) (newline))

(define-method print args (call-next-method))
(print 'a 'b 'c)
#|
around:before
:before(a b c)
abc
:after(a b c)
around:after
|#

:aroundは一番外側を包み、call-next-methodが呼ばれた際のみに続くメソッドチェインを起動します。また、チェイン全体の戻り値は:aroundメソッドが返した値になります。
:beforeはメソッド本体が呼ばれる手前で呼び出されます。戻り値は捨てられます。
:primaryはメソッド本体です。:aroundが上書きしない限りこのメソッドの戻り値がメソッドチェインの全体の戻り値として使用されます。
:afterはメソッド本体が呼ばれた直後に呼ばれます。:before同様戻り値は捨てられます。
ちなみに、この動作はCLでも同様です。

では、これが使えると何が嬉しいのでしょう？

例えば、 DB接続を考えて見ます。DBの実装によってクエリ発行などは別にする必要があるけど、コネクションが生きているかチェックするのは共通でやりたい、なんてこと考えたことありませんか？素直に考えれば、以下のようになるでしょう。

;; super class method
(define-method select ((c <connection>) query)
  (check-connection c))

;; Database dependent layer
(define-method select ((c <oracle-connection) query)
  (call-next-method)
  (oracle-select c query))

DBの種類が増えた場合でもcall-next-methodを呼べば共通の処理はしてくれるという寸法です。でも毎回書くのはだるいですよね？そこでメソッドqualifierです。この場合なら事前処理に:beforeを使って以下のように書くことができます。

;; super class method
;; implementation limitation. Sagittarius needs primary method
(define-method select ((c <connection>) query))
(define-method select :before ((c <connection>) query)
  (check-connection c))

;; Database dependent layer
(define-method select ((c <oracle-connection) query)
  (oracle-select c query))

これでDBの実装が増えてもselectメソッドではコネクションが生きているかを自動で判別してくれます。(もちろん、check-connectionがエラーを投げなければ意味はありませんが・・・)

もう一例見てみましょう。JavaでAspectJを使っている方なら馴染み深いと思いますが、既存のメソッドの前後に事前と事後処理を入れたい場合というのがあるかと思います。例えばあるメソッドがエンティティの状態を変更します、ユーザーはその状態の変化を捉えて何かしらの通知を行うというのを考えて見ます。以下は簡単なコード例です。

;; pseudo method
;; This is in somewhere the library so users can't
;; change.
;; do something useful and return the new entity
(define (fire-event entity event) 'new-entity)

;; wrap it with qualifier
;; just stub to call original
(define-method fire-event args (call-next-method))

(define-method fire-event :around args
  ;; check args length and get the entity's state
  (print args)
  ;;
  (let ((r (call-next-method)))
    ;; check the result of the entity and notify
    (print r)
    r))
#|
(fire-event 'entity 'event)
;;> (entity event)
;;> new-entity
;;=> new-entity
|#

この例では:aroundが実際のメソッドを呼び出していますが、引数が不正であったりする場合は呼ばないことも可能です。Lisp:よくある正解で上げられているToo dynamicはこの機能を使えば実現できそうです*1。

次回*2はMOPを使って総称関数にユーザー定義のqualifierを足してみます。

*1コンパイラが手続きの呼び出しをインライン展開している場合等全てに対応できるわけではありません。
*2紹介部分が予定したよりかなり長くなってしまったので分割しました。