Gauche:infoファイルにアクセス
yamasushi(2013/04/15 13:29:11 UTC)interactive/info.scmをもとに、infoファイルにアクセスするライブラリを作っています。
Gauche:マニュアルにアクセスで使用しています。
- yamasushi(2013/04/16 10:34:39 UTC)メモ化をつかわずに、instance-poolを使うようにしました。
;;; gaucheのinfoにアクセスする。
;;; interactive/info.scmを改造した。
;;; もとになったblog
;;; Gaucheのinfo関数の表示を日本語にするには - 再帰の反復
;;; http://d.hatena.ne.jp/lemniscus/20100326/1269613137
;;; interactive/info.scm - online helper
;;;
;;; Copyright (c) 2000-2012 Shiro Kawai <shiro@acm.org>
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;;
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;;
;;; 3. Neither the name of the authors nor the names of its contributors
;;; may be used to endorse or promote products derived from this
;;; software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;
; TODO gaucheマニュアル以外のinfoで使えるかどうか試す
; TODO INFOファイルの木を歩いて列挙していく処理
(define-module textj.info-lib
(use srfi-1)
(use gauche.dictionary)
(use gauche.collection)
;(use gauche.lazy)
;(use gauche.generator)
(use util.match)
(use gauche.mop.instance-pool)
;;
(use text.info)
;;
(use komono-combinator)
;(use pretty-print)
;(use komono-dict)
(export
<info-index-node> <cached-info-file>
get-index-node grep-node
)
)
(select-module textj.info-lib)
;----------------------------------------
; <info-file>
; 等価判定を付加する。
(define-method object-equal? ( (obj1 <info-file> ) (obj2 <info-file>) )
(string=? (~ obj1 'path) (~ obj2 'path) ) )
; hashを定義する
(define-method object-hash ((a <info-file>)) (hash (~ a 'path) ) )
; refを定義する
; node-name ---> node or #f
(define-method ref ((obj <info-file>) (key <string>))
(info-get-node obj key))
(define-method write-object((obj <info-file>) port)
(format port "<info-file :path ~a>" (~ obj 'path) ) )
;----------------------------------------
; <cahced-info-file>
(define-class <cached-info-file> (<instance-pool-mixin>)
[ (name :init-keyword :name)
(file :init-keyword :file)
(key-converter-table :init-value #f )] )
(define-method object-equal? ( (obj1 <cached-info-file> ) (obj2 <cached-info-file>) )
(string=? (~ obj1 'file 'path) (~ obj2 'file 'path) ) )
; hashを定義する
(define-method object-hash ((a <cached-info-file>)) (hash (~ a 'file 'path) ) )
(define-method info-get-node ((obj <cached-info-file>) nodename )
(info-get-node (~ obj 'file) nodename ) )
; refを定義する
; node-name ---> node or #f
(define-method ref ((obj <cached-info-file>) (key <string>))
;#?=key
(if-let1 kc (and-let* [ [ key-converter-table (~ obj 'key-converter-table) ] ]
(dict-get key-converter-table key #f ) )
(get-index-node obj key kc )
(~ obj 'file key) ) )
(define-method write-object((obj <cached-info-file>) port)
(format port "<cached-info-file :name ~a :file ~a>" (~ obj 'name) (~ obj 'file) ) )
;----------------------------------------
; <info-node>
; 等価判定を付加する。
(define-method object-equal? ( (obj1 <info-node> ) (obj2 <info-node>) )
(and
(equal? (~ obj1 'file) (~ obj2 'file))
(equal? (~ obj1 'name) (~ obj2 'name)) ) )
; hashを定義する
(define-method object-hash ((a <info-node>)) (hash (list (~ a 'file 'path) (~ a 'name) ) ) )
(define-method write-object((obj <info-node>) port)
(format port "<info-node :name ~a :file ~a>" (~ obj 'name) (~ obj 'file) ) )
;----------------------------------------
; <info-index-node>
; 索引ノード
(define-class <info-index-node> (<dictionary> <instance-pool-mixin> )
[node index])
; dictionary protocol
(define-method dict-get ((d <info-index-node>) key :optional default)
(dict-get (~ d 'index) key default ) )
(define-method dict-put! ((d <info-index-node>) key value)
(dict-put! (~ d 'index) key value) )
(define-method dict-exists? ((d <info-index-node>) key)
(dict-exists? (~ d 'index) key ) )
(define-method dict-delete! ((d <info-index-node>) key)
(dict-delete! (~ d 'index) key ) )
(define-method dict-fold ((d <info-index-node>) proc seed)
(dict-fold (~ d 'index) proc seed))
(define-method call-with-iterator ((d <info-index-node>) proc . keys)
(apply call-with-iterator (~ d 'index) proc keys) )
; (make <info-index-node> node key-converter)
; node .... <info-node>
; key-converter .... menuキーワードを索引キーに変換する
(define-method initialize ((self <info-index-node>) initargs)
(next-method)
(match initargs
[(node key-converter)
(slot-set! self 'node node)
(slot-set! self 'index (make-tree-map string=? string<?))
(for-each
(match-lambda
[ (keyword . nodename)
(dict-push! (~ self 'index) (key-converter keyword) nodename) ] )
(info-parse-menu node ) ) ] ) )
(define-method object-equal? ( (obj1 <info-index-node> ) (obj2 <info-index-node>) )
(object-equal? (~ obj1 'node) (~ obj2 'node) ) )
(define-method object-hash ((a <info-index-node> )) (object-hash (~ a 'node)))
; key ---> node-name
(define-method ref ((obj <info-index-node>) (key <string>))
(~ obj 'index key) )
;索引ノードを取得する
; info ... node-nameからnodeを取得するrefが定義されているもの
; info node-name ---> <info-index-node> or #f
(define (get-index-node info node-name key-converter)
(and-let* [[node (info-get-node info node-name) ]]
(if-let1 obj (instance-pool-find <info-index-node> ($ equal? node $ (cut ~ <> 'node) $))
(begin
;(format #t "found ~a\n" obj)
obj)
(make <info-index-node> node key-converter ) ) ) )
;----------------------------------------
; index-tableのキーをgrepして、結果を照会してリストにする
; ( node名 nodeの中身 )のリスト
; info ... ノード名からnodeを取得するrefが定義されているもの
; info-index ... keywordからノード名を引くことができるdictionary
; info -> <dictionary> -> (x -> y) -> [<string>] or <boolean>
; predは通常は正規表現をわたされるが、フィルタなので手続きでも良い
(define (grep-node info info-index pred )
($ (andfn-fn$ map
($ (~pack$ list 'name 'content) $ ~ info $) )
$ (andfn$ delete-duplicates)
$ (if-listfn$
($ concatenate
$ filter identity
$ (cut dict-map <>
(^(k v)
(and (pred k) v) ) ) $) )
info-index ) )
;----------------------------------------
;;; gaucheのinfoにアクセスする総元締めクラス
;;; interactive/info.scmを改造した。
;;; もとになったblog
;;; Gaucheのinfo関数の表示を日本語にするには - 再帰の反復
;;; http://d.hatena.ne.jp/lemniscus/20100326/1269613137
;;; interactive/info.scm - online helper
;;;
;;; Copyright (c) 2000-2012 Shiro Kawai <shiro@acm.org>
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; 1. Redistributions of source code must retain the above copyright
;;; notice, this list of conditions and the following disclaimer.
;;;
;;; 2. Redistributions in binary form must reproduce the above copyright
;;; notice, this list of conditions and the following disclaimer in the
;;; documentation and/or other materials provided with the distribution.
;;;
;;; 3. Neither the name of the authors nor the names of its contributors
;;; may be used to endorse or promote products derived from this
;;; software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;
; TODO gaucheマニュアル以外のinfoで使えるかどうか試す
; TODO INFOファイルの木を歩いて列挙していく処理
(define-module textj.info-root
(use srfi-1)
(use util.match)
(use gauche.dictionary)
(use gauche.collection)
(use gauche.lazy)
(use gauche.generator)
(use gauche.mop.instance-pool)
;;
(use file.util)
(use gauche.process)
(use text.info)
(use komono-combinator)
;(use pretty-print)
(use komono-dict)
(use textj.info-lib)
(export
<info-root>
infoset get-info-paths info-node-open-file
info-node-index-generator info-node-index-lseq
info-content-generator info-content-lseq
make-lazy-ofni-hash
viewer
)
)
(select-module textj.info-root)
; texinfo/info/filesys.hより
(define *default-infopath* "/usr/local/info:/usr/info:/usr/local/lib/info:/usr/lib/info:\
/usr/local/gnu/info:/usr/local/gnu/lib/info:/usr/gnu/info:/usr/gnu/lib/info:/opt/gnu/info:\
/usr/share/info:/usr/share/lib/info:/usr/local/share/info:/usr/local/share/lib/info:\
/usr/gnu/lib/emacs/info:/usr/local/gnu/lib/emacs/info:/usr/local/lib/emacs/info:/usr/local/emacs/info")
;----------------------------------------
; <info-root>
; infoアクセスの元締め
; TODO pagerの指定をパラメータ化する。
(define-class <info-root> ()
[ (pager :allocation :virtual
:slot-ref
(^[self] (or (sys-getenv "PAGER")
(find-file-in-paths "less")
(find-file-in-paths "more") ) ) )
(*f->key-converter-table* :init-value (make-hash-table 'string=? ) )
(*src* :init-value #f)
(src :allocation :virtual
:slot-ref (^[self] (~ self '*src*) )
:slot-set! (^[self info-src]
(slot-set! self '*src* info-src)
;;
(let1 t (~ self '*f->key-converter-table*)
(dict-for-each info-src
(^(tag x) (match x
[((? string? name) (? ($ (cut subtype? <> <dictionary> ) $ class-of $) index ) )
(dict-put! t name
($ (cut alist->hash-table <> 'string=?)
$ dict-map index
(^(type node&kc)
;#?=node&kc
(apply cons node&kc) ) ) ) ]
[_ (values)] ) ) ) ) ) )
] )
(define-method initialize ((root <info-root>) initargs)
(next-method)
(match initargs
[(info-src) (slot-set! root 'src info-src)] ) )
(define-method viewer( (root <info-root>) )
(let1 pager (~ root 'pager)
(if (or (equal? (sys-getenv "TERM") "emacs")
(equal? (sys-getenv "TERM") "dumb")
(not (sys-isatty (current-output-port)))
(not pager ))
display
(lambda (s)
(let1 p (run-process pager :input :pipe)
;; NB: ignore SIGPIPE, for the pager may be terminated prematurely.
;; This is not MT safe.
(let1 h #f
(with-signal-handlers
((SIGPIPE => #f))
(lambda ()
(guard (e (else #f))
(display s (process-input p)))
(close-output-port (process-input p))
(process-wait p))))))
) ) )
; info-file-name ----> info
; ※ 一般の場合、key-converterテーブル参照は失敗するかもしれない
(define-method ref ((root <info-root>) (key <string>))
;#?= "ref ((root <info-root>) "
(rlet1 info (info-node-open-file root key)
(if-let1 key-converter-table (and
($ not $ ~ info 'key-converter-table ) ; 既に設定されているときはスキップする
(dict-get (~ root '*f->key-converter-table*) key #f) )
(begin
(slot-set! info 'key-converter-table key-converter-table) )
) ) )
; info-file tag ----> infoのセット
; infoファイルカタログ info-srcをみて、infoのリストを取得する
; info-src : tagから (infoの名前 索引定義) or (tag ... ) を引くdictionary
; 索引定義 : type<symbol> から (索引ノード名 索引用のkey-converter)を返すdictionary
(define-method infoset ((root <info-root>) (tag <symbol>))
(unless (~ root 'src) (error "srcがセットされていない"))
(let1 info-src (~ root 'src)
(let loop [ (v (dict-get info-src tag #f)) ]
(match v
[ #f #f]
[ (? symbol? symbol alias) ($ loop $ dict-get info-src alias #f) ]
[ ((? symbol? tags) ... ) (append-map loop tags) ]
[ ( (? string? name) (? ($ (cut subtype? <> <dictionary> ) $ class-of $) index ) )
(list (cons name index) ) ] ) ) ) )
(define-method get-info-paths((root <info-root>))
;#?=(sys-getenv "INFOPATH")
(append-map (cut string-split <> #\:)
(append
(cond-list
[(sys-getenv "INFOPATH") => identity] )
`(,*default-infopath*) ) ) )
(define-method find-info-file ( (root <info-root>) (fname <string>) )
(let ((paths (get-info-paths root)))
(or (find-file-in-paths fname
:paths paths
:pred (lambda (p)
(or (file-is-readable? p)
(file-is-readable? #`",|p|.gz")
(file-is-readable? #`",|p|.bz2"))))
(errorf "couldn't find info file ~s in paths: ~s" fname paths))
))
; info-file <string> ---> info <info-file>
(define-method info-node-open-file ((root <info-root>) (name <string>))
(if-let1 obj (instance-pool-find <cached-info-file> ($ string=? name $ (cut ~ <> 'name) $))
(begin
;(format #t "found ~a\n" obj)
obj)
(and-let* [[ f ($ open-info-file $ find-info-file root name)]
[ obj (make <cached-info-file> :name name :file f) ] ]
obj ) ) )
; infoファイルカタログ (~ root 'src) から、
; [type <info-index-node> ]のジェネレータを生成
; type は'module,'function,'classなどの索引のタイプ(索引定義から)
;
; info-src : tagから (infoの名前 索引定義) or (tag ... ) を引くdictionary
; 索引定義 : type<symbol> から (索引ノード名 索引用のkey-converter)を返すdictionary
(define-method info-node-index-generator ((root <info-root>) :key (tag 'default) (type-filter (^_ #t) ) )
(unless (~ root 'src) (error "srcがセットされていない") )
($ apply gappend
$ map
(match-lambda
[(info-file . node-names)
(and-let* [[info (~ root info-file )]]
(gmap
(match-lambda [(t n kc) `(,t ,(~ info n) )])
($ x->generator
$ filter ($ type-filter $ car $)
$ dict->alist node-names ) )) ] )
$ infoset root tag) )
(define-method info-node-index-lseq ((root <info-root>) . arg)
($ generator->lseq $ apply info-node-index-generator root arg) )
; contentを列挙する
; pred : x->y ; キーワードを選ぶ
; [node-name content index-type <info-index-node> ]のジェネレータ
(define-method info-content-generator ((root <info-root>) pred . rest )
($ gconcatenate $ gmap x->generator
$ gfilter-map
(match-lambda
[(index-type index-node )
($ (andfn$ (map$ (^x (append x `(,index-type ,index-node )))))
$ grep-node (~ index-node 'node 'file) index-node pred)
])
$ apply info-node-index-generator root rest) )
(define-method info-content-lseq ((root <info-root>) pred . rest )
($ generator->lseq $ apply info-content-generator root pred .rest ))
;----------------------------------------
;逆引き用辞書の(遅延)生成
(define-method make-lazy-ofni-hash ((root <info-root>) :optional (tag 'default) )
(lazy-dict
(make-hash-table 'string=?)
(^t (for-each
(match-lambda
[(_ info-index )
(dict-for-each info-index
(^(k v)
(for-each (cut dict-push! t <> k) v) ) ) ])
(info-node-index-lseq root :tag tag) ) ) ) )