Gauche:万能アクセサを使う

Gauche:万能アクセサを使う

yamasushi(2013/04/19 09:30:27 UTC)万能アクセサを使う小物をまとめてみます。


関連ファイル

空気を読んでrefを定義するproxyを生成

<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リソースアクセス

; 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

; 万能アクセサ的な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) )

~~ object,symbolが交互にあらわれる参照構文

Gauche:スロットアクセス

(~~ 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>)

flipしてアクセス

(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$する

(※ 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) ) )

Gauche:スロットアクセス

Tag: gauche.procedure

More ...