Gauche:モジュールの列挙

Gauche:モジュールの列挙

yamasushi(2013/04/19 09:23:41 UTC)モジュールを列挙して、exportやclassの列を生成してみます。


モジュールの列挙

ライブラリアクセスのための関数library-for-eachのパタンには"**"を指定できないので、全モジュールを列挙するには不便です。そこで、Gauche:遅延globを使い列挙します。

; 下記サイトを参考にした
; Vim+Gaucheでの作業環境の設定 - 再帰の反復
; http://d.hatena.ne.jp/lemniscus/20100308/1268022750
; > Gauche用の補完語ファイルを作るには上の参照先にある
; > http://www.katch.ne.jp/~leque/software/misc/mk_gosh_completions
; > を使えばよいのだけど
; > * gauche.matrix(gauhce.arrayからautoloadされている)を読んだところでエラーが出た。
; > * obsoleteなモジュールを読み込んで注意される。
; > * モジュールを読み込まなくても使える基本的な関数が補完語に含まれない。
; > だったので、いくらか変更した。

; TODO autoloadなファイルを指定できないか?
; TODO コアに組み込まれたのちに互換性のために設けられたモジュールの識別?(util.listなど)
; TODO autoloadの関係を調べる処理? module間の依存関係。

(define-module gauche-modules
  (use gauche.parameter)
  (use srfi-1)
  (use srfi-13)
  (use file.util)
  (use text.tr)
  (use gauche.generator)
  (use gauche.lazy)
  (use gauche.dictionary)
  (use util.match)
  ;
  (use komono-dict) ; 辞書小物
  (use komono-glob)
  (use komono-combinator)
  (export
    predefined?
    predefined-modules obsoleted-modules
    exclude-path-prefixes
    library-modules-generator library-modules-lseq
    gauche-library-generator gauche-library-lseq gauche-library-for-each
    gauche-modules-generator gauche-modules-lseq gauche-modules-for-each
    predefined-modules-generator predefined-modules-lseq
    module-source
    lazy-gauche-modules
    *lazy-modules-table*
  )
)
(select-module gauche-modules)

(define exclude-path-prefixes (make-parameter '("~/gauche")))

(define predefined-modules (make-parameter '(null scheme gauche)))
(define obsoleted-modules  (make-parameter '(gauche.let-opt gauche.validator gauche.singleton)))

;オブジェクトがpredefindかどうか
; TODO util.listのcond-listのようにmacroで再定義しているケースに対応できていない
(define-method predefined? ( (sym <symbol>) obj)
  (let/cc cont
    (for-each
      (^m ;#?=m
        (let1 mod (find-module m)
          (dict-for-each (module-table mod)
            (^[k _ ]
              (and-let* [ [_ (eq? k sym) ]
                          [v (global-variable-ref mod k #f)]
                          [_ (eq? obj v) ] ] (cont #t) ) ) ) ) )
    (predefined-modules) )
    #f ) )

; ここで使う、(modsym . path)にpredefinedもあわせる
(define (predefined-modules-generator)
  ($ x->generator $ map (cut cons <> #f) (predefined-modules) ) )
(define (predefined-modules-lseq)
  ($ x->lseq $ map (cut cons <> #f) (predefined-modules) ) )

; ( name . moduleのパス ) のジェネレータ
; name : ファイルがモジュールを定義していればsymbolにする。
; そうでなければ、文字列 "hoge/foo"のようなまま。
(define (gauche-library-generator)
  (let [[exclude-path-prefixes
            (map (cut sys-normalize-pathname <> :expand #t) (exclude-path-prefixes) ) ]]
    ($ gmap
        (^x (match x
              [ (file . path)
                (if-let1 v (and-let* [[modsym  (path->module-name file)]
                                      [_       (library-has-module? path modsym)] ]
                                    `(,modsym . ,path) )
                  v x ) ] ) )
    $ gconcatenate
    $ gmap
        (^p
          (let1 rxp ($ string->regexp $ format #f "^~a\\/(.*)\\.sc[mi]$" $ regexp-quote p)
            ($ gmap (^s (cons ((rxp s) 1 ) s ) )
              $ gappend
                ($ glob-generator $ build-path p "**" "*.scm")
                ($ glob-generator $ build-path p "**" "*.sci") ) ) )
    $ x->generator
    $ filter
        (^p
          (and (absolute-path? p)
              (not (any (cut string-prefix? <> p) exclude-path-prefixes) ) ) )
        *load-path*)) )

(define (gauche-library-lseq) ($ generator->lseq $ gauche-library-generator ))

; predefined以外のライブラリモジュール
(define (library-modules-generator :optional (exclude-modules '() ) )
  (let1 exclude (append (obsoleted-modules) exclude-modules )
    ($ gfilter
        (every-pred
          ($ symbol? $ car $)
          ($ not $ (cut memq <> exclude ) $ car $) )
    $ gauche-library-generator) ) )

(define (library-modules-lseq . rest)
  ($ generator->lseq $ apply library-modules-generator rest ) )

; predefined + libararyモジュール
(define (gauche-modules-generator . rest )
  (gappend
    (predefined-modules-generator)
    (apply library-modules-generator rest ) ) )

(define (gauche-modules-lseq . rest) ($ generator->lseq $ apply gauche-modules-generator rest ))

; (proc sym path) .... sym : モジュール名のシンボル , path : モジュールのパス
(define (gauche-modules-for-each proc . rest)
  (generator-for-each
    (match-lambda [(modsym . path) (proc modsym path )])
    (apply gauche-modules-generator rest) ) )

(define (gauche-library-for-each proc )
  (generator-for-each
    (match-lambda [(modname . path) (proc modname path )])
    (gauche-library-generator) ) )

; モジュール・ソース対応表
; TODO load順にしたがって1:1になるようにすること。
;
; *lazy-module-table*を参照してロード元を取得
(define-method module-source ( (modsym <symbol>) )
  (dict-get (force *lazy-modules-table*) (symbol->string modsym) #f ) )

(define-method module-source ( (mod <module>) )
  (module-source (module-name mod) ) )

(define-method module-source ( (rx <regexp>) )
  ($ sort!
  $ filter-map (cut dict-get (force *lazy-modules-table*) <> #f)
  $ filter rx $ force lazy-gauche-modules) )

; モジュールは文字列でもつ。
; tree-mapにしておく。(整列される)
(define *lazy-modules-table*
  (lazy-dict
    (make-tree-map string=? string<?)
    (^t
      (gauche-modules-for-each
        (^ (modsym path)
          (let1 modstr (symbol->string modsym)
            (unless (dict-exists? t modstr)
              (dict-put! t modstr path) ) ) ) ) ) ) )

; 全モジュールのリスト
(define lazy-gauche-modules
  (delay
    ($ dict-keys $ force *lazy-modules-table*) ) )

;(gauche-library-for-each ($ format #t "<<< ~s ~s>>>\n" $*) )
;(gauche-modules-for-each ($ format #t "<<< ~s ~s>>>\n" $*) )
;(print (force lazy-gauche-modules))
;(for-each print (library-modules-lseq))

exportの列挙

(define-module gauche-exports
  (use gauche.parameter)
  (use srfi-1)
  (use util.match)
  (use gauche.lazy)
  (use gauche.dictionary)
  ;
  (use pretty-print)
  (use komono-combinator)
  (use gauche-modules)
  (export
      ; predefinedに登録ずみのオブジェクトを持つモジュール
      ; (maybe autoload)
      default-library-modules
      ; predefinedでないモジュールの、predefinedに登録ずみのオブジェクト
      ; (maybe autoload)
      default-library-objects-lseq

      ; predefinedに登録されていないオブジェクトを持つモジュール
      library-modules
      ; predefinedでないモジュールの、predefinedに登録されていないオブジェクト
      library-objects-lseq

      ; predefinedのオブジェクト
      predefined-objects-lseq

      gauche-export-less-modules
      exclude-modules
      gauche-exports
      predefined-objects-lseq
      gauche-module&export-lseq
      gauche-module&object-lseq
      ;
      whereis
      ) )
(select-module gauche-exports)

; TODO コアに組み込まれたのちに互換性のために設けられたモジュールの識別?(util.listなど)

; 下記サイトを参考にした
; Vim+Gaucheでの作業環境の設定 - 再帰の反復
; http://d.hatena.ne.jp/lemniscus/20100308/1268022750

;Gauche:モジュールの列挙 http://practical-scheme.net/wiliki/wiliki.cgi?Gauche%3a%e3%83%a2%e3%82%b8%e3%83%a5%e3%83%bc%e3%83%ab%e3%81%ae%e5%88%97%e6%8c%99
; Shiro(2013/04/24 01:25:46 UTC): with-moduleおよび、evalに(interaction-environment)
; を指定することで特定のモジュールに読み込ませているようですが、多分意図どおりに動いていないと思います。
;
; (1) with-moduleは「コンパイル時のモジュール」を指定するもので、実行時のモジュールがどうなっているかは関係ありません。
;     evalは実行時に働きます。
;
; (2) interaction-environmentは無条件でuserモジュールを返すので、(eval '(require foo) (interaction-environment))
;     は現在のモジュールとか関係なしに、userモジュールで(require foo)を実行します。
;     つまりuserモジュールにfooが読み込まれることになります。
;
; sandboxとしてモジュールを使いたいなら、実行時に無名のモジュールを作ってそれをevalの第二引数に渡します。
; with-moduleは不要です。
;
; ただ、requireの動作 (一度ロードしたモジュールはロードしないようにする) がどうしても必要なのでなければ、
; evalとrequireを使うのではなくloadを使った方がいいんじゃないかと思います。
; evalが本当に必要な場面って少ないです。
; evalを使いたくなったら、一旦他の方法がないかどうか考えてみると良いと思います。

(define exclude-modules
  (make-parameter
    '(
      gl
      gl.glut
      gl.math3d
      gl.simple-image
      gl.simple.image
      gl.simple.viewer
      graphics.gd
      ) ) )

(define %symbol-list-sort! (cut sort! <>
        (^[x y]
            (string<?
              ($ symbol->string x)
              ($ symbol->string y) ) )))

(define %module-list-sort! (cut sort! <>
        (^[x y]
            (string<?
              ($ symbol->string $ module-name x)
              ($ symbol->string $ module-name y) ) )))

(define (%%load-module modsym path)
  (let1 modpath (module-name->path modsym)
    (unless (provided? modpath)
      (load path :environment (make-module #f) )
      (provide modpath ) )
    ;
    ; 念の為チェックしておく
    (unless (provided?   modpath) (errorf "~aがprovideされていない" modpath) )
    (unless (find-module modsym ) (errorf "~aがみつからない" modsym) )
  ) )

; mod-hashで指定したモジュールを全部requireする。
; all-modulesで得たリストとmod-hashを照合して、共通のモジュール&exportsリストと、
; thunkを実行してその結果と組みにして返す
(define-method gauche-require-modules ( (mod-hash <dictionary>) :optional (thunk (^[] #f) ) )
  (dict-for-each mod-hash
    (^ (modsym path)
      (if path (%%load-module modsym path) ) ) )
  (cons
    ($ map
        (^m (cons m
          (if ($ dict-get mod-hash $ module-name m )
            (case (module-exports m)
              [(#t) ($ dict-keys $ module-table m) ]
              [else => identity ])
            ($ dict-keys $ module-table m) ) ) )
     $ filter ($ dict-exists? mod-hash $ module-name $) (all-modules) )
    (thunk) ) )

; exprortシンボルをリストにして返す
(define (gauche-exports :optional (module-thunk #f))
  ($ %symbol-list-sort!
    $ delete-duplicates!
    $ concatenate!
    $ map cdr
    $ car (gauche-require-modules
            (alist->hash-table
              (if module-thunk (module-thunk) (gauche-modules-lseq (exclude-modules) ) ) ) ) ) )

; exportがないモジュール
(define (gauche-export-less-modules)
    ($ %module-list-sort!
      $ map car
      $ filter! (match-lambda [(m . syms) (null? syms) ] )
      $ car (gauche-require-modules
              ($ alist->hash-table
                $ gauche-modules-lseq (exclude-modules) ) ) ) )

; thunkを指定したとき (thunk-result == (thunk) @ gauche-require-modules )
; mod-pred : thunk-result -> module -> *
; obj-pred : thunk-result -> export-name -> obj -> *
(define (%gauche-module&object-lseq mod-pred obj-pred
                                    :optional (thunk #f) (module-thunk #f) )

    ($ lconcatenate
      $ (match-lambda [( m&sym . t )
          ($ lmap (match-lambda
                    [ (m . syms)
                      ($ lmap (cut cons m <> )
                        $ lfilter
                            (match-lambda
                              [#f #f]
                              [(sym obj) (obj-pred t sym obj) ] )
                        $ lmap
                            (pack$ (^[sym obj] (and obj (list sym obj) ) )
                              identity
                              (cut global-variable-ref m <> #f) )
                        $ x->lseq syms )
                    ] )
            $ lfilter (match-lambda [(m . _ ) (mod-pred t m) ] )
            $ x->lseq m&sym ) ])
        (gauche-require-modules
          (alist->hash-table
            (if module-thunk
              (module-thunk)
              (gauche-modules-lseq (exclude-modules) ) ) )
          (if thunk thunk (^[] #f) ) ) ) )

(define-method gauche-module&object-lseq ((class <class>)
                                            :key
                                              (module-pred (^ _ #t))
                                              (object-pred (^ _ #t))
                                              (module-thunk #f ) )
  (%gauche-module&object-lseq
    module-pred
    (^[ _ sym obj]
      (and (is-a? obj class ) (object-pred sym obj) ) )
    #f module-thunk ) )

(define-method gauche-module&object-lseq ((rx <regexp>)
                                            :key
                                              (module-pred (^ _ #t))
                                              (object-pred (^ _ #t))
                                              (module-thunk #f ) )
  (%gauche-module&object-lseq
    module-pred
    (^[ _ sym obj]
      (and ($ rx $ symbol->string sym) (object-pred sym obj) ) )
    #f module-thunk ) )


(define-method gauche-module&object-lseq (:key (thunk #f)
                                              (module-pred (^ _ #t))
                                              (object-pred (^ _ #t))
                                              (module-thunk #f ) )
  (%gauche-module&object-lseq
    module-pred object-pred thunk module-thunk ) )

; predefined objects
(define (predefined-objects-lseq)
  (gauche-module&object-lseq
    :thunk (^[] #f)
    :module-thunk predefined-modules-lseq) )

; predefinedでないモジュールの、predefinedに登録されていないオブジェクト
; library object (predefineではない。)
(define (library-objects-lseq)
  (gauche-module&object-lseq
    :thunk (^[] #f)
    :object-pred (^(_ sym obj) (not (predefined? sym obj) ) )
    :module-thunk (^[] (library-modules-lseq (exclude-modules) ) ) ) )

; predefinedでないモジュールの、predefinedに登録ずみのオブジェクト
; (maybe autoload)
; library object (predefineに含まれているlibraryオブジェクト )
(define (default-library-objects-lseq)
  (gauche-module&object-lseq
    :thunk (^[] #f)
    :object-pred (^(_ sym obj) (predefined? sym obj) )
    :module-thunk (^[] (library-modules-lseq (exclude-modules) ) ) ) )

; predefinedに登録ずみのオブジェクトを持つモジュール
; (maybe autoload)
(define (default-library-modules)
  ($ %module-list-sort!
  $ delete-duplicates!
  $ lmap (match-lambda [(mod sym obj) mod] )
  $ default-library-objects-lseq) )

; predefinedに登録されていないオブジェクトを持つモジュール
(define (library-modules)
  ($ %module-list-sort!
  $ delete-duplicates!
  $ lmap (match-lambda [(mod sym obj) mod] )
  $ library-objects-lseq) )

; autoloadされるモジュール
(define (autoloaded-modules)
  ($ %module-list-sort!
  $ lset-difference! eq? (default-library-modules) (library-modules) ) )

; whereis exportの定義元を表示
; TODO method は検索できない。
; TODO predefinedのときはどうする?
(define-method whereis ((rx <regexp>))
  ($ sort!
    $ delete-duplicates!
    $ lfilter-map (match-lambda [ (mod _ _) (module-source mod) ] )
    $ gauche-module&object-lseq rx ) )

(define-method whereis ((name <string>))
  ($ whereis $ string->regexp $ format #f "^~a$" $ regexp-quote name) )

;----------------------------

;($ for-each print $ gauche-module&object-lseq #/set!$/ :object-pred (^[_ obj] (is-a? obj <generic>) ) )
;($ for-each print
;  $ gauche-module&object-lseq
;      #/set!$/
;      :object-pred (^[_ obj](is-a? obj <procedure>))
;      :module-thunk predefined-modules-lseq )

;($ for-each print $ gauche-module&object-lseq <class> )
;($ for-each print $ gauche-module&object-lseq <generic> )

;($ for-each (match-lambda [(m sym proc)
;                            (let1 info (slot-ref proc 'info)
;                              (format #t "[~a] ~s (~a)\n" (class-of info) info m ) )])
;  $ gauche-module&object-lseq <procedure> )

;($ for-each print $ gauche-module&object-lseq <macro> )

;(print ($ sort! $ map symbol->string $ gauche-exports) )

;(for-each print (default-library-modules))
;(for-each print (library-modules))
;
;(print "exportの一部がdefaultモジュールに取り込まれているもの")
;(for-each ($ print $ module-name $) (lset-intersection eq? (default-library-modules) (library-modules)) )
;(print "exportのすべてがdefaultモジュールに取り込まれているもの")
;(for-each ($ print $ module-name $) (autoloaded-modules))

;(for-each print (default-library-objects-lseq))
;($ print $ gauche-exports predefined-modules-lseq)

;(let1 predefs (gauche-exports predefined-modules-lseq)
;  ($ for-each (match-lambda [(mod sym obj) (print "[" (module-name mod) "] " sym ) ])
;  $ gauche-module&object-lseq
;    :thunk (^[] #f)
;    :module-pred (^[ _ mod ] ($ null?
;                                $ lset-difference eq? (module-exports mod) predefs ))
;    :object-pred (^(_ sym obj) (not (predefined? sym obj) ) )
;    :module-thunk (^[] (library-modules-lseq (exclude-modules) ) ) ) )

; (for-each ($ print $ (cut take <> 2) $) (library-objects-lseq))

;($ for-each ($ print $ module-name $) $ gauche-export-less-modules)

クラスの列挙

(define-module gauche-classes
  (use srfi-1)
  (use util.match)
  (use gauche.lazy)
  ;;
  (use gauche-exports)
  (use komono-combinator)
  (use pretty-print) ; pretty printer
  (export
    gauche-classes-lseq
    gauche-sub-classes-lseq
    gauche-super-classes-lseq
    gauche-classes-for-each
  ) )
(select-module gauche-classes)

; 下記サイトを参考にした

; Vim+Gaucheでの作業環境の設定 - 再帰の反復
; http://d.hatena.ne.jp/lemniscus/20100308/1268022750

; [Gauche] 環境に存在するすべてのクラスを得る - karetta.jp
; http://karetta.jp/article/blog/oneline/008181

; [Gauche] クラス階層図を描く - karetta.jp
; http://karetta.jp/article/blog/oneline/008183

; class
(define (gauche-classes-lseq ) (gauche-module&object-lseq <class> ) )

(define-method gauche-sub-classes-lseq ((super <class>) )
  (gauche-module&object-lseq <class> :object-pred (^[_ obj] (subtype? obj super) ) ) )

(define-method gauche-super-classes-lseq ((sub <class>) )
  (gauche-module&object-lseq <class> :object-pred (^[_ obj] (subtype? sub obj) ) ) )

; proc : <module> -> <symbol> -> <class> -> *
(define (gauche-classes-for-each proc)
  (for-each (pack$ proc car cadr caddr)
      (gauche-classes-lseq) ) )

;(gauche-classes-for-each print)
;(for-each print (gauche-sub-classes-lseq <dictionary> ) )
;(for-each print (gauche-sub-classes-lseq <ordered-dictionary> ) )
;(for-each print (gauche-super-classes-lseq <dictionary> ) )
;(for-each print (gauche-super-classes-lseq <ordered-dictionary> ) )


applicableの列挙

(define-module gauche-applicables
  (use srfi-1)
  (use util.match)
  (use gauche.lazy)
  ;;
  (use gauche-modules)
  (use gauche-exports)
  (use komono-combinator)
  (use pretty-print) ; pretty printer
  (export
    applicable?
    gauche-applicables
    gauche-generics-lseq
    gauche-procedures-lseq
    gauche-methods-lseq
    gauche-applicables-lseq
  ) )
(select-module gauche-applicables)

; yamasushi http://chaton.practical-scheme.net/gauche/a/2013/04/23#entry-5175d115-7eca6
; <procedure>の名前はinfoスロットを見るのだろうと思うのですが、文字列だったりシンボルだったりしているのです。
; 名前を見る方法があるのでしょうか?(また、無名かどうかの判定法など。)
; shiro http://chaton.practical-scheme.net/gauche/a/2013/04/23#entry-5175d55d-e93b1
; procedure-infoの仕様はまだ確定しておらず、将来変更される可能性が高いです。
; 今のところ、
;   SUBR(Cで実装された手続き)だと文字列、
;   Schemeで実装されたトップレベル手続きはシンボル、
;   ネストしている手続きの場合はトップレベルからの名前のリスト、
;   メソッドは名前とspecializerのリスト、
;   case-lambdaの場合はもっと複雑。
;   名前がコンパイラに判定できなかった箇所は#fが入ってます。
; Schemeでは仕様上は全て無名関数ですんで、名前はあくまで参考です
; (最初にトップレベルに束縛された時の名前、等)

; generic
(define (gauche-generics-lseq) (gauche-module&object-lseq <generic> ) )

; method
(define (gauche-methods-lseq) (gauche-module&object-lseq <method> ) )

; procedure
(define (gauche-procedures-lseq) (gauche-module&object-lseq <procedure> ) )

; applicables
; object-applyが新しく定義されるかもしれないので、毎回実行するようにする
(define (gauche-applicables)
  `( ,<procedure>
    ,@($ delete-duplicates
        $ map ($ car $ (cut ~ <> 'specializers ) $)
        $ ~ object-apply 'methods ) ) )

(define-method applicable? ((obj <top>))
  (any (cut subtype? (class-of obj) <> ) (gauche-applicables) ) )

(define (gauche-applicables-lseq . rest)
  (apply gauche-module&object-lseq
    :thunk gauche-applicables
    :object-pred (^( supers sym x) (any (cut is-a? x <> ) supers ) )
    rest ) )

;($ for-each print $ gauche-methods-lseq )
;($ for-each print $ gauche-generics-lseq)
;($ for-each print $ gauche-procedures-lseq )
;($ for-each print $ gauche-applicables-lseq)
;($ for-each print $ gauche-applicables-lseq :module-thunk predefined-modules-lseq )




Tag: Module

More ...