Scheme:MOP:パラメタライズドクラス

builderとmodifierでチェックする

目的

「文字列のみを要素に持つリスト」とか、「整数のみを要素に持つベクタ」とかいうクラスが欲しいことがたまにある。

強い型付き言語だとこういうクラスを多用するが、 Schemeではそのへんは運用で何とかしてしまう場合が多い。しかし、規模が大きくなってきてデータの境界条件をきちんとマネージしたい場合や、メタデータを用いていろいろやりたい場合には、型が「何でも有り」だと困ることもある。

validator

Gaucheでは例えばvalidatorメタクラスを使ってスロットの値にvalidateを噛ましてやるってことは出来なくはない。

  (use gauche.validator)
  (use srfi-1)

  (define-class <list-of-strings> ()
    ((elements :validator (lambda (o v)
                            (if (and (list? v)
                                     (every string? v))
                                v
                                (error "bad type of object" v)))
      ))
     :metaclass <validator-meta>)

STklosならvirtual slotとかactive slotで同様のことが出来るであろう。

しかし、「××のみを要素に持つ○○」の××と○○が変わる度に上のクラス定義をやるのはめんどくさい。C++ならテンプレートで一発だ。もちろん、マクロを使ってたとえば

  (define-collection-of-xx-class <list-of-strings> (list? string?))

というフォームが上のクラス定義に展開されるようにすることは簡単だし現実的でもあるんだが、なんかテンプレートによる解法に比べて裏技的というか、あんまり綺麗な感じがしない。

そこで、敢えてMOPでやってみるの巻。

トライ

とりあえずざくっと。

 (use srfi-1)
 (use gauche.collection)
 (use gauche.mop.validator)

 (define-class <collection-of-meta> (<validator-meta> <class>)
   ((element-type :init-keyword :element-type :init-value <top>)
    (collection-type :init-keyword :collection-type :init-value <list>))
   )

 (define-method compute-slots ((class <collection-of-meta>))
   (let ((empty-collection (call-with-builder
                            (ref class 'collection-type)
                            (lambda (put! get) (get)))))
     (slot-push! class 'direct-slots
                 `(elements :validator
                            ,(lambda (o v)
                               (if (and (is-a? v (ref (class-of o) 'collection-type))
                                        (every (cute is-a? <> (ref (class-of o) 'element-type)) (coerce-to <list> v)))
                                   v
                                   (error "bad type of value" v)))
                            :init-value ,empty-collection))
     (next-method)))

これで、

 (define <list-of-strings> 
   (make <colleciton-of-meta> :element-type <string> :collection-type <list>))
 (define <vector-of-integer>
   (make <collection-of-meta> :element-type <integer> :collection-type <vector>))

みたいなことが出来る。これならクラスをパラメタライズしたメタクラスからスペシャライズしたクラスが作られているという実感がある。インスタンスは確かにスペシャライズした型しか受け付けない。

  (define a (make <list-of-strings>))
  (ref a 'elements)  ==> '()
  (set! (ref a 'elements) 3) ==> error
  (set! (ref a 'elements) '("abc" "def")) ==> ok
  (set! (ref a 'elements) '("abc" 3))  ==> error

なお、これを書いているうちに、:validatorみたいにスロットアクセサをカスタマイズしたらslot-bound? がうまく動かなくなるというバグをみつけた。上のコードでは初期値を設定してこれを回避している。

実用化

上のコードでは<list-of-string>のインスタンスの持つコレクションにアクセスする時にはいちいちelementsスロットにアクセスしなければならない。 <list-of-string>が<sequence>を継承するようにして、コレクションフレームワークとシーケンスフレームワークを定義するようにしてやれば、 <list-of-string> に対してmapをかけたり出来るようになる。そのへんも自動化したいね。もう眠くなったのでまた今度。

builderとmodifierでチェックする

yamasushi(2013/05/14 22:37:52 UTC) validatorを使わずに、builderとmodifierでチェックしてみました。

→Gauche:MOP:GenericCollection

(use gauche.sequence)

(define-class <generic-sequence-meta> [<class>]
  [ (seq-type  :init-keyword :seq-type  :init-value #f)
    (elem-type :init-keyword :elem-type :init-value #f)] )

(define-method compute-slots ((class <generic-sequence-meta>))
  (and-let* [ [seq-type (slot-ref class'seq-type)]
              [empty    (with-builder (seq-type add! get) (get) ) ]]
    (slot-push! class 'direct-slots
                `(seq :init-keyword :seq :init-value ,empty) ) )
  (next-method) )

(define-class <generic-sequence> [<sequence>] [] :metaclass <generic-sequence-meta> )

(define-method write-object ((self <generic-sequence>) port)
  (format port "<generic-sequence ~a >" (slot-ref self'seq) ) )

(define-method write-object ((self <generic-sequence-meta>) port)
  (format port "<generic-sequence-meta seq-type:~a elem-type:~a >"
    (slot-ref self'seq-type) (slot-ref self'elem-type) ) )

(define-method size-of ((self <generic-sequence>))
  (and-let* [[seq (slot-ref self'seq)]] (size-of seq) ) )

(define-method call-with-iterator ((self <generic-sequence>) proc :key start)
  (and-let* [[seq (slot-ref self'seq) ]] (call-with-iterator seq proc :start start) ) )

(define-method call-with-builder ((class <generic-sequence-meta>) proc :key size)
  (and-let* [ [seq-type  (slot-ref class'seq-type)  ]
              [elem-type (slot-ref class'elem-type) ]]
    (with-builder (seq-type add! get)
      (proc
        ;add!
        (^x (unless (is-a? x elem-type) (errorf "~a is not ~a" x elem-type) )
          (add! x) )
        ;get
        (^[] (make class :seq (get) ) ) ) ) ) )

(define-method referencer ((self <generic-sequence>))
  (^[obj index]
    (if-let1 seq (slot-ref obj'seq)
      ((referencer seq) seq index)
      (errorf "no seq ~a" obj) ) ) )

(define-method modifier ((self <generic-sequence>))
  (and-let* [ [class      (class-of self) ]
              [seq-type   (slot-ref class'seq-type)  ]
              [elem-type  (slot-ref class'elem-type) ] ]
    (^ [obj index x]
      (unless (is-a? x elem-type) (errorf "~a is not ~a" x elem-type) )
      (if-let1 seq (slot-ref obj'seq)
        ((modifier seq) seq index x)
        (errorf "no seq ~a" obj) ) ) ) )

(define-method subseq ((self <generic-sequence>) start end)
  (and-let* [ [class (class-of self) ]
              [seq   (slot-ref self'seq) ]]
    (make class :seq (subseq seq start end) ) ) )

(define-method (setter subseq) ((self <generic-sequence>) start (vals <sequence> ))
  (and-let* [ [class   (class-of self)]
              [vals    (coerce-to class vals) ]
              [seq     (slot-ref self'seq)]
              [val-seq (slot-ref vals'seq)] ]
      ((setter subseq) seq start val-seq) ) )

(define-method (setter subseq) ((self <generic-sequence>) start end (vals <sequence> ))
  (and-let* [ [class   (class-of self)]
              [vals    (coerce-to class vals) ]
              [seq     (slot-ref self'seq)]
              [val-seq (slot-ref vals'seq)] ]
      ((setter subseq) seq start end val-seq) ) )

(define-class <list-of-strings>    [<generic-sequence>] [] :metaclass <generic-sequence-meta> :elem-type <string>  :seq-type <list> )
(define-class <vector-of-integer>  [<generic-sequence>] [] :metaclass <generic-sequence-meta> :elem-type <integer> :seq-type <vector> )

(define x (map-to <list-of-strings> number->string (iota 10 2 3)) )
(for-each-with-index (pa$ format #t "[~a] ~s~%") x )
(newline)
(for-each-with-index (pa$ format #t "[~a] ~s~%") (subseq x 2 5) )
(set! (subseq x 2 5) #("aa" "bb" "cc"))
(newline)
;(for-each-with-index (pa$ format #t "[~a] ~s~%") (subseq x 2 5) )
(for-each-with-index (pa$ format #t "[~a] ~s~%") x)

(set! (~ x 6) "ss")
(set! (~ x 6) 11) ;==> ERROR

(for-each-with-index (pa$ format #t "[~a] ~s~%") x)

Tags: gauche.mop.validator, MOP