「文字列のみを要素に持つリスト」とか、 「整数のみを要素に持つベクタ」とかいうクラスが欲しいことがたまにある。
強い型付き言語だとこういうクラスを多用するが、 Schemeではそのへんは運用で何とかしてしまう場合が多い。 しかし、規模が大きくなってきてデータの境界条件をきちんとマネージしたい 場合や、メタデータを用いていろいろやりたい場合には、型が「何でも有り」 だと困ることもある。
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をかけたり出来るようになる。 そのへんも自動化したいね。もう眠くなったのでまた今度。
yamasushi(2013/05/14 22:37:52 UTC) validatorを使わずに、builderとmodifierでチェックしてみました。
(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