Gauche:infoファイルにアクセス

Gauche:infoファイルにアクセス

yamasushi(2013/04/15 13:29:11 UTC)interactive/info.scmをもとに、infoファイルにアクセスするライブラリを作っています。
Gauche:マニュアルにアクセスで使用しています。

;;; 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) ) ) ) )

Tags: gauche.interactive.info, gauche.mop.instance-pool

More ...