yamasushi(2013/04/19 09:30:27 UTC)万能アクセサを使う小物をまとめてみます。
<dictionary>のときはdict-get,<procedure>なら関数適用,<module>ならglobal-variable-ref。
(define-class <%ref-adapter%> [<instance-pool-mixin>]
[ (proxy :init-keyword :proxy :init-value #f )
(getter :init-keyword :getter :init-value #f )
(setter :init-keyword :setter :init-value #f )
] )
(define-method %pool-make (proxy :optional (getter #f) (setter #f))
(if-let1 obj (instance-pool-find <%ref-adapter%>
(every-pred
($ eq? proxy $ flip slot-ref 'proxy $)
($ eq? getter $ flip slot-ref 'getter $)
($ eq? setter $ flip slot-ref 'setter $) ) )
obj
(make <%ref-adapter%> :proxy proxy :getter getter :setter setter) ) )
; compare
(define-method object-equal? ( (x <%ref-adapter%>) (y <%ref-adapter%>) )
(equal? (slot-ref* x'proxy x'getter x'setter) (slot-ref* y'proxy y'getter y'setter) ) )
; get
(define-method ref ((self <%ref-adapter%>) key . rest)
(let* [ [proxy (slot-ref self 'proxy )]
[getter (slot-ref self 'getter )] ]
(cond
[(and proxy getter)
(if (null? rest)
(getter proxy key)
(apply getter proxy key rest) ) ]
[proxy
(if (null? rest)
(proxy key)
(apply proxy key rest) ) ]
[getter
(if (null? rest)
(getter key)
(apply getter key rest) ) ]
[else (errorf "cannot ref self:~a key:~a rest:~a" self key rest) ] ) ) )
; set
(define-method (setter ref) ((self <%ref-adapter%>) key value . rest)
(let* [ [proxy (slot-ref self 'proxy )]
[setter (slot-ref self 'setter )] ]
(cond
[ (and proxy setter)
(if (null? rest)
(setter proxy key value)
(apply setter proxy key value rest) ) ]
[proxy
(if (null? rest)
(proxy key value)
(apply proxy key value rest) ) ]
[setter
(if (null? rest)
(setter key value)
(apply setter key value rest) ) ]
[else (errorf "cannot set self:~a key:~a value:~a rest:~a" self key value rest) ] ) ) )
(define-method write-object ((self <%ref-adapter%>) port)
($ format port "<%ref-adatper% proxy:~a getter:~a setter:~a>" $* slot-ref* self'proxy self'getter self'setter ) )
; 空気を読んでアクセッサ付きにする
(define-class <x->~> [<singleton-mixin>] [])
(define x->~ (instance-of <x->~>) )
(define-method object-apply ((self <x->~>) (proc <procedure>))
(%pool-make proc) )
(define-method object-apply ((self <x->~>) (getter <procedure>) (setter <procedure>))
(%pool-make #f getter setter ) )
(define-method object-apply ((self <x->~>) (dict <dictionary>))
(%pool-make dict dict-get dict-put!) )
(define-method object-apply ((self <x->~>) (module <module>))
(%pool-make module global-variable-ref) )
(define-method ref ( (x <procedure>) (self <x->~>) ) (self x) )
(define-method ref ( (x <dictionary>) (self <x->~>) ) (self x) )
(define-method ref ( (x <module>) (self <x->~>) ) (self x) )
gosh> (~ gauche-info-root "*source*" "*module*" "gauche.generator")
*** ERROR: no applicable method for #<generic ref (19)> with arguments (#<<gauche-module-finder> 0x8bfac18> "gauche.generator")
Stack Trace:
_______________________________________
0 (eval expr env)
At line 173 of "/usr/local/share/gauche-0.9/0.9.4_pre3/lib/gauche/interactive.scm"
gosh> (~ gauche-info-root "*source*" "*module*" x->~ "gauche.generator")
("/usr/local/share/gauche-0.9/0.9.4_pre3/lib/gauche/generator.scm")
gosh> (~ (find-module 'gauche) 'cond-list)
*** ERROR: object of class #<class <module>> doesn't have such slot: cond-list
Stack Trace:
_______________________________________
0 (eval expr env)
At line 173 of "/usr/local/share/gauche-0.9/0.9.4_pre3/lib/gauche/interactive.scm"
gosh> (~ (find-module 'gauche) x->~ 'cond-list)
#<macro cond-list>
; global accessor
(define-class <module-proxy> [<singleton-mixin>] [])
(define module-proxy (instance-of <module-proxy>) )
(define-method ref ((self <module-proxy>) (name <symbol>))
(find-module name) )
(define-method ref ((self <module-proxy>) (path <string>))
(find-module (path->module-name path) ) )
(define-class <system-proxy> [<singleton-mixin>] [])
(define system-proxy (instance-of <system-proxy>) )
(define-method ref ((self <system-proxy>) (gtag <keyword> ) )
(case gtag
[(:uname ) (sys-uname)]
[(:hostname ) (sys-gethostname) ]
[(:domainname) (sys-getdomainname) ]
[(:cwd ) (sys-getcwd ) ]
[(:gid ) (sys-getgid ) ]
[(:egid ) (sys-getegid ) ]
[(:uid ) (sys-getuid ) ]
[(:euid ) (sys-geteuid ) ]
[(:groups ) (sys-getgroups) ]
[(:login ) (sys-getlogin) ]
[(:pgrp ) (sys-getpgrp) ]
[(:pid ) (sys-getpid) ]
[(:ppid ) (sys-getppid) ]
[(:times ) (sys-times) ]
[(:ctermid ) (sys-ctermid) ]
;;
[(:strerror ) (x->~ sys-strerror) ]
;;
[(:pgid ) (x->~ sys-getpgid sys-setpgid ) ]
[(:rlimit ) (x->~ sys-getrlimit sys-setrlimit ) ]
[(:env ) (x->~ sys-getenv sys-setenv ) ]
;;
[else (errorf "unknown tag ~a" else)]
) )
(define-method (setter ref) ((self <system-proxy>) (gtag <keyword>) value)
(case gtag
[(:gid ) (sys-setgid value) ]
[(:uid ) (sys-setuid value) ]
[ else (errorf "unknown tag ~a for setter" else)]
) )
gosh> (~ module-proxy 'gauche x->~ 'cond-list) #<macro cond-list> gosh> (~ system-proxy :env "PATH") "/usr/lib/lightdm/lightdm:/usr/local/sbin:/usr/local/bin:/usr/sbin:/usr/bin:/sbin:/bin:/usr/games:/home/shuji/gauche/command" gosh> (~ system-proxy :env "TMP") #f gosh> (set! (~ system-proxy :env "TMP") "hoge") #<undef> gosh> (~ system-proxy :env "TMP") "hoge"
; 万能アクセサ的なslot-ref
; ~を改造
(define %slot-ref*
(getter-with-setter
(case-lambda
[(obj selector) (slot-ref obj selector)]
[(obj selector . more) (apply slot-ref* (slot-ref obj selector) more)])
(case-lambda
[(obj selector val) ((setter slot-ref) obj selector val)]
[(obj selector selector2 . rest)
(apply (setter slot-ref*) (slot-ref obj selector) selector2 rest)])))
(define-method slot-ref* (obj (sym <symbol>) . syms )
(apply %slot-ref* obj sym syms) )
(~~ obj 'x) = (~ obj 'x) (~~ obj 'x 'y) = (~ obj 'x 'y) (~~ obj1 obj2 'x 'y obj3 'u 'v 'w ) == (list (~~ obj1 obj2 'x 'y ) (~~ obj3 'u 'v 'w ) ) == (list (list (~ obj1 'x 'y) (list obj2 'x 'y) ) (~ obj3 'u 'v 'w) )
(define (%ref% refn pred . arg)
($ (^x (if (= (length x) 1) (car x) x ) )
$ map
(match-lambda
[( ((? (complement pred) obj) ) ( (? pred syms) ... ) )
(apply refn obj syms) ]
[( ((? (complement pred) objs) ... ) ( (? pred syms) ... ) )
(map (cut apply refn <> syms) objs) ] )
$ flip slices 2 $ group-sequence arg :key pred)
)
(define (%flip-ref% refn pred . arg)
($ (^x (if (= (length x) 1) (car x) x ) )
$ map
(match-lambda
[( ( (? pred syms) ... ) ((? (complement pred) obj) ) )
(apply refn obj syms) ]
[( ( (? pred syms) ... ) ((? (complement pred) objs) ... ) )
(map (cut apply refn <> syms) objs) ] )
$ flip slices 2 $ group-sequence arg :key pred)
)
; (slot-ref* obj1 obj2 'a 'b obj3 'x)
; == (list
; (list (slot-ref* obj1 'a 'b) (slot-ref* 'a 'b))
; (slot-ref* obj3 'x) )
(define (slot-ref* . arg) (apply %ref% %slot-ref* symbol? arg ) )
(define (flip-slot-ref* . arg) (apply %flip-ref% %slot-ref* symbol? arg ) )
(define (~~ . arg) (apply %ref% ~ symbol? arg ) )
(define (flip~~ . arg) (apply %flip-ref% ~ symbol? arg ) )
gosh> (~~ (find-module 'gauche) 'table) #<hash-table eq? 0x8204ed8> gosh> (~~ (find-module 'gauche) 'table 'cond-list) #<gloc gauche#cond-list> gosh> (~~ (find-module 'util.list) 'table) #<hash-table eq? 0x8398208> gosh> (~~ (find-module 'util.list) 'table 'cond-list) #<gloc util.list#cond-list> gosh> (~~ (find-module 'gauche) 'table (find-module 'gauche.generator) 'table) (#<hash-table eq? 0x8204ed8> #<hash-table eq? 0x82bd3c0>) gosh> (~~ (find-module 'gauche) (find-module 'gauche.generator) 'table) (#<hash-table eq? 0x8204ed8> #<hash-table eq? 0x82bd3c0>) gosh> (~~ (find-module 'gauche) (find-module 'util.list) 'table 'cond-list ) (#<gloc gauche#cond-list> #<gloc util.list#cond-list>)
(fliprはGauche:コンビネータプログラミングを参照。)
; (flip~ 'hoge 'foo x) = (~ x 'hoge 'foo) (define (flip~ . arg) (apply flipr ~ arg) )
(いまひとつ単純になっていないので改良の余地ありです。)yamasushi
; ~head-propagate$
; procの第一引数にobjを参照したものを部分適用したものを返す
(define (~head-propagate$ proc obj . selectors)
(pa$ proc (apply ~ obj selectors) ) )
(define (slot-head-propagate$ proc obj . selectors)
(pa$ proc (apply slot-ref* obj selectors) ) )
; ~tail-propagate$
; procの最後にobjを参照したものを部分適用したものを返す
(define (~tail-propagate$ proc obj . selectors)
(^ arg
(apply proc `(,@arg ,(apply ~ obj selectors)))))
(define (slot-tail-propagate$ proc obj . selectors)
(^ arg
(apply proc `(,@arg ,(apply slot-ref* obj selectors)))))
(define (~$ . selectors) (cut apply ~ <> selectors) ) (define (slot-ref*$ . selectors) (cut apply slot-ref* <> selectors) )
; ~の分配
; TODO setterはどうする？？？
; (*~ `(,x ,y) 'a 'b) --> `(,(~ x 'a 'b) ,(~ y 'a 'b))
(define *~
(match-lambda*
[ ( (objs ... ) . selectors ) (map (cut apply ~ <> selectors ) objs) ]
[ (obj . selectors) (apply ~ obj selectors) ] ) )
; slot-refの分配
; TODO setterはどうする？？？
(define *slot-ref
(match-lambda*
[ ( (objs ... ) . selectors ) (map (cut apply slot-ref* <> selectors ) objs) ]
[ (obj . selectors) (apply slot-ref* obj selectors) ] ) )
; ~で参照したオブジェクトを比較する関数をつくる (define (~compare$ cmp . keys) (^(x y) (cmp (apply ~ x keys) (apply ~ y keys) ) ) ) ; 指定スロットでオブジェクトを比較する関数をつくる (define (slot-compare cmp key x y) (cmp (slot-ref x key) (slot-ref y key) ) ) (define (slot-compare$ cmp key) (pa$ slot-compare cmp key) ) (define (slot-compare*$ cmp . keys) (^(x y) (cmp (apply slot-ref* x keys) (apply slot-ref* y keys) ) ) )
(※ pack$ はGauche:コンビネータプログラミングにコードがあります。)
; 万能アクセサに値を通して、指定手続きで固める手続きを返す
; TODO ~の多段参照にも対応するか？
(define (~pack$ packer . keys)
(apply pack$ packer
(map (^k (cut ~ <> k)) keys) ) )
(define (slot-ref-pack$ packer . keys)
(apply pack$ packer
(map (^k (cut slot-ref <> k)) keys) ) )
Tag: gauche.procedure