#:g1: MOPで契約プログラミング

Posted 2013-12-22 17:50:00 GMT

(Metaobject Protocol(MOP) Advent Calendar 2013参加エントリ)

 Metaobject Protocol(MOP) Advent Calendar 2013 23日目です。
今回は、Common Lispで契約プログラミングを実現した例があるのでこれを眺めつつ、マクロで色々やっているところをMOPを使うようにしてみたいと思います。

Design by Contract in Common Lisp

 dbc.lispは、Matthias Hölzl氏がBertrand Meyer氏のEiffelにインスパイアされて作ったものです。

dbc.lispの構成

 まず、dbc.lispでは、エラー時に発生させるコンディションが細かく定義されています。

 次に、不変条件、事前/事後条件のチェックの差し込みにCLOSのメソッドコンビネーションを利用します。
メソッドコンビネーションのカスタマイズもMOPに触るところではあるのですが、CLの場合、define-method-combinationで定義するので、直接触っている感じではありません。
定義は下記のようになりますが、:precondition、:around、:invariant、:before、プライマリ、:after、:postcondition が使えます。
それぞれのメソッドは、同じものが集められいて、どんな風にcall-methodで実行されるかが記述されています。
これが、compute-effective-methodに渡されて合体されます。

(define-method-combination dbc (&key (precondition-check t)
                                     (postcondition-check t)
                                     (invariant-check t))
    ((precondition (:precondition . *))
     (around (:around))
     (invariant (:invariant . *))
     (before (:before))
     (primary () :required t)
     (after (:after))
     (postcondition (:postcondition . *)))
  (labels ((call-methods (methods)
             (maplist #'(lambda (method-list)
                          `(call-method ,(car method-list)
                                        ,(cdr method-list)))
                      methods))
	   (raise-error (error-type methods)
	     (maplist #'(lambda (method-list)
                          `(unless (call-method ,(car method-list)
                                                ,(cdr method-list))
                             (error ',error-type
                                    :description
                                    ,(second (method-qualifiers
                                              (car method-list))))))
                      methods)))
    (let* ((form (if (or before after (rest primary))
		     `(multiple-value-prog1
                        (progn ,@(call-methods before)
                               (call-method ,(first primary)
                                            ,(rest primary)))
                        ,@(call-methods (reverse after)))
                     `(call-method ,(first primary) ,(rest primary))))
	   (around-form (if around
                            `(call-method ,(first around)
                                          (,@(rest around)
                                             (make-method ,form)))
                            form))
	   (pre-form (if (and precondition-check precondition)
			 `(if (or ,@(call-methods precondition))
			      ,around-form
                              (progn
                                ,@(raise-error 'precondition-error
                                               precondition)))
                         around-form))
	   (post-form (if (and postcondition-check postcondition)
                          `(multiple-value-prog1
                             ,pre-form
                             (unless (and ,@(call-methods postcondition))
                               ,@(raise-error 'postcondition-error
                                              postcondition)))
                          pre-form))
	   (inv-form (if (and invariant-check invariant)
			 `(multiple-value-prog1
                            (progn
                              (unless (and ,@(call-methods
                                              invariant))
                                ,@(raise-error
                                   'before-invariant-error
                                   invariant))
                              ,post-form)
                            (unless (and ,@(call-methods invariant))
                              ,@(raise-error
                                 'after-invariant-error
                                 invariant)))
                         post-form)))
      inv-form)))

 次にチェックに使うメソッドですが、不変条件の検査に check-invariant を使い、クラスのライタとリーダにそれぞれ、:invariantメソッドを付加することによって読み書き時に実行されるようになっています。
これに加えて、make-instanceでもcheck-invariantが実行されるようにしてあります。
これらは、どういう風にして定義されるかというと、基本的にマクロで上記のメソッドのコードが生成されるようになっています。

(defun getf-and-remove (name list &optional acc)
  "Find NAME in the alist LIST.  Returns nil as first value if NAME is
not found, the valus associated with NAME otherwise.  The second value
returned is LIST with the first occurence of pair (NAME value)
removed."
  (if (null list)
    (values nil (reverse acc))
    (if (eql (caar list) name)
      (values (cdar list) (append (reverse acc) (rest list)))
      (getf-and-remove name (rest list) (cons (first list) acc)))))

(defun define-slot-generics (slot) "Returns a list with the reader and writer generic functions for a slot. The generic functions have method combination type `dbc'." (let ((accessor (getf (rest slot) :accessor))) (let ((reader (or (getf (rest slot) :reader) accessor)) (writer (or (getf (rest slot) :writer) (when accessor `(setf ,accessor))))) (list (when reader `(ensure-generic-function ',reader :lambda-list '(object) :method-combination #-mcl '(dbc:dbc) #+mcl (ccl::%find-method-combination nil 'dbc nil))) (when writer `(ensure-generic-function ',writer :lambda-list '(new-value object) :method-combination #-mcl'(dbc:dbc) #+mcl (ccl::%find-method-combination nil 'dbc nil)))))))

(defun define-slot-accessor-invariants (class-name slot) "Returns a list with method definitions for reader and writer invariants." (let ((accessor (getf (rest slot) :accessor))) (let ((reader (or (getf (rest slot) :reader) accessor)) (writer (or (getf (rest slot) :writer) (when accessor `(setf ,accessor))))) (list (when reader `(defmethod ,reader :invariant ((object ,class-name)) (check-invariant object))) (when writer `(defmethod ,writer :invariant (value (object ,class-name)) (declare (ignore value)) (check-invariant object)))))))

(defun define-check-invariant-method (invariant class-name) "Returns a list containing the method on CHECK-INVARIANT specialized for CLASS-NAME and executing INVARIANT." `((defmethod check-invariant ((object ,class-name)) (when (funcall ,invariant object) (call-next-method)))))

(defmacro defclass (&body body) (destructuring-bind (name supers &optional slots &rest options) body (multiple-value-bind (invariant-form new-options) (getf-and-remove :invariant options) (let ((documented-invariant (cadr invariant-form))) (let ((invariant (or documented-invariant (car invariant-form)))) `(progn ,@(if slots (apply #'append (mapcar (lambda (slot) (define-slot-generics slot)) slots)) '()) (cl:defclass ,name ,supers ,slots ,@new-options) ,@(when invariant (define-check-invariant-method invariant name)) ,@(when slots (apply #'append (mapcar (lambda (slot) (define-slot-accessor-invariants name slot)) slots)))))))))

(eval-when (:compile-toplevel :load-toplevel :execute) (defgeneric check-invariant (object) (:documentation "Methods on the generic `check-invariant' are used by the dbc method combination to perform the invariant check and should not directly be defined by the user.")) ) ; eval-when (defmethod check-invariant (object) "Default invariant, always true." (declare (ignore object)) t)

(defmethod make-instance (class-name &rest initargs) (let ((object (apply #'cl:make-instance class-name initargs))) (unless (check-invariant object) (error 'creation-invariant-error)) object))

 defclassとmake-instanceが置き換えられていて、defclassではメソッドの定義がずらっと並ぶようになっています。

MOPを使って書き直してみよう

 標準のdefclassとmake-instanceを置き換えるのは名前の衝突等を考えるとあまり嬉しくないので、ここはMOPでメソッドを追加するようにしてみよう、ということで書いたのが下記です。

(defclass dbc (standard-class)  
  ((invariant :initarg :invariant
              :initform '() 
              :reader invariant)))

(defmethod c2mop:validate-superclass ((c dbc) (sc standard-class)) T)

(eval-when (:compile-toplevel :load-toplevel :execute) (defgeneric check-invariant (object) (:documentation "Methods on the generic `check-invariant' are used by the dbc method combination to perform the invariant check and should not directly be defined by the user.")) ) ; eval-when (defmethod check-invariant (object) "Default invariant, always true." (declare (ignore object)) t)

(defun slot-writers (class) (loop :for s :in (c2mop:class-direct-slots class) :append (c2mop:slot-definition-writers s)))

(defun slot-readers (class) (loop :for s :in (c2mop:class-direct-slots class) :append (c2mop:slot-definition-readers s)))

(defun define-invariant-methods (name metaclass) (when (eql 'dbc metaclass) (let ((class (find-class name))) (eval `(defmethod check-invariant ((object ,name)) (when (funcall ,(let* ((inv (invariant class)) (inv/doc (cadr inv))) (or inv/doc (first inv))) object) (call-next-method)))) (when (slot-readers class) (dolist (m (slot-readers class)) (ensure-generic-function m :lambda-list '(object) :method-combination '(dbc:dbc)) (eval `(defmethod ,m :invariant ((object ,name)) (check-invariant object))))) (when (slot-writers class) (dolist (m (slot-writers class)) (ensure-generic-function m :lambda-list '(new-value object) :method-combination '(dbc:dbc)) (eval `(defmethod ,m :invariant (value (object ,name)) (declare (ignore value)) (check-invariant object))))))))

(defmethod c2mop:ensure-class-using-class :after ((class null) name &key metaclass) (define-invariant-methods name metaclass))

(defmethod c2mop:ensure-class-using-class :after ((class dbc) name &key metaclass) (define-invariant-methods name metaclass))

(defmethod make-instance ((class-name dbc) &key) (let ((object (call-next-method))) (unless (check-invariant object) (error 'creation-invariant-error)) object))

 defclassの定義時にマクロを展開するのではなくて、(ensure-class-using-class null)と(ensure-class-using-class dbc)時にメソッドを定義するようにしています。
(ensure-class-using-class null)を変更するのは、なんか気持ち悪い気がしますが、他に方法はあるのでしょうか。一応dbcの時だけ反応するようにしていますが、もっと良い方がある気がします。
それとメソッドを生成するフォームがdefmethodを利用しているため、これも気持ち悪いことになっています。これも改善したいところ。
make-instanceは、dbcメタクラスで不変条件をチェックするように変更。

実行してみる

 CLを使っている人以外には実感しづらいですがCLパッケージをそのままuseできているところが改善点です。
オリジナルでは、:metaclassの指定はありませんが、改変版は必要になります。ここが、めんどくさいといえば、めんどくさいところです。

(cl:defpackage "DBC-MOP-TEST"
  (:use "DBC-MOP" "CL"))

(in-package "DBC-MOP-TEST")

(defclass test () ((slot1 :accessor slot1 :initarg :slot1 :initform 0)) (:metaclass dbc) (:invariant (lambda (class) (format t "~& >> Invariant check for class ~A~%" class) (numberp (slot-value class 'slot1)))))

(defgeneric test-dbc (arg1 arg2) (:method-combination dbc :invariant-check nil))

(defmethod test-dbc :precondition "first arg zero" ((m test) (n test)) (format t "~& >> precondition (test test)~%") (not (zerop (slot1 m))))

(defmethod test-dbc ((m test) (n test)) (/ (slot1 n) (slot1 m)))

 こういう定義で、事前条件のチェック

(test-dbc (make-instance 'test) (make-instance 'test))
;>>   >> Invariant check for class #<TEST {101BF22FB3}>
;>>   >> Invariant check for class #<TEST {101BF23A13}>
;>>   >> precondition (test test)
;>>   >> Invariant check for class #<TEST {101BF22FB3}>
;>>   >> Invariant check for class #<TEST {101BF22FB3}>
;>>   >> precondition (test test)
;>>   >> Invariant check for class #<TEST {101BF22FB3}>
;>>   >> Invariant check for class #<TEST {101BF22FB3}>
;>>!! error: Precondition violation: first arg zero.

testのslot1は初期値0なので、0除算チェックにひっかかる

(test-dbc (make-instance 'test :slot1 2) (make-instance 'test :slot1 8))
;>>   >> Invariant check for class #<TEST {101B93BD13}>
;>>   >> Invariant check for class #<TEST {101B93FDE3}>
;>>   >> precondition (test test)
;>>   >> Invariant check for class #<TEST {101B93BD13}>
;>>   >> Invariant check for class #<TEST {101B93BD13}>
;>>   >> Invariant check for class #<TEST {101B93FDE3}>
;>>   >> Invariant check for class #<TEST {101B93FDE3}>
;>>   >> Invariant check for class #<TEST {101B93BD13}>
;>>   >> Invariant check for class #<TEST {101B93BD13}>
;>>  
;=>  4

チェック通過

まとめ

 もっと綺麗に書けると良かったのですが、小汚くなりました。
不変条件は、スロットごとメソッドを付ける位なら、指定もスロットごとにしてみても良いような気もします。
改善のアドバイスがありましたら是非お願いします!

comments powered by Disqus