Gauche:マニュアルにアクセス

Gauche:マニュアルにアクセス

yamasushi(2013/04/11 06:38:36 UTC)interactive/info.scmをもとに、マニュアルを検索するライブラリをつくってみました。述語を指定して、マッチするキーをひいて、取得したマニュアルデータの見出し部分をさらにフィルタします。
($マクロを多用したので、schemeのコードのように見えないかもしれません。(汗)

;;; 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 コード構成の整理。
; TODO シンプルなヘルプ
; TODO key ---> 見出し map
; TODO caddrの展開
; TODO <dictionary> <ordered-dictionary>などの重要だがdocumentに索引のないものに対応
; TODO 実際のクラス・モジュール情報を見て処理する

(define-module textj.gauche-info (extend textj.info-lib textj.info-root)
  (use gauche.config)
  (use srfi-1)
  (use srfi-13)
  (use gauche.mop.singleton)
  (use text.tree)
  (use gauche.generator)
  (use gauche.dictionary)
  (use gauche.sequence)
  (use gauche.lazy)
  (use util.match)
  (use text.info)

  (use gauche-modules)
  (use pretty-print) ; debug
  (use komono-dict)
  (use komono-combinator)
  (use komono-regexp)
  (export
    gauche-info-root <gauche-info-root> <info-index-node>
    gauche-source        <gauche-source>
    gauche-module-finder <gauche-module-finder>
    <%node>
    ;;
    info-string-generator info-string-lseq
    info-deftp&body-generator info-deftp&body-lseq
    info-deftp-generator info-deftp-lseq
    info-node-function-jp info-node-function-en
    info-node-variable-jp info-node-variable-en
    info-node-class-jp    info-node-class-en
    info-node-module-jp   info-node-module-en
    process-deftp-string-list
  )
)
(select-module textj.gauche-info)

(define *source* "*source*") ; ソースファイルを見る。
(define *index-node-source-module-jp*   "*module*")
(define *index-node-source-function-jp* "*function*")
(define *index-node-source-variable-jp* "*variable*")
(define *index-node-source-class-jp*    "*class*")
(define *index-node-source-macro-jp*    "*macro*")

(define *info-file-jp*      "gauche-refj.info")       ; 日本語infoを見る
(define *info-file-en*      "gauche-refe.info")       ; 英語infoを見る
(define *info-file-dev-en*  "gauche-deve.info")       ; 開発者manual
(define *info-file-gl-en*   "gauche-gl-refe")         ; Gauche gl

(define *index-node-function-jp* "Index - 手続きと構文索引")
(define *index-node-variable-jp* "Index - 変数索引")
(define *index-node-class-jp*    "Index - クラス索引")
(define *index-node-module-jp*   "Index - モジュール索引")

(define *index-node-function-en* "Function and Syntax Index")
(define *index-node-variable-en* "Variable Index")
(define *index-node-class-en*    "Class Index")
(define *index-node-module-en*   "Module Index")

(define *index-node-dev-function-en* "Function and Macro Index")
(define *index-node-dev-type-en*     "Type Index")
(define *index-node-dev-variable-en* "Variable Index")

(define *index-node-gl-function-en* "Function and Syntax Index")
(define *index-node-gl-variable-en* "Variable Index")
(define *index-node-gl-class-en*    "Class Index")
(define *index-node-gl-module-en*   "Module Index")

(define *toc-lib-gauche-jp*      "ライブラリモジュール - Gauche拡張モジュール")
(define *toc-lib-srfi-jp*        "ライブラリモジュール - SRFI")
(define *toc-lib-utilities-jp*   "ライブラリモジュール - ユーティリティ")

(define *toc-lib-gauche-en*      "Library modules - Gauche extensions")
(define *toc-lib-srfi-en*        "Library modules - SRFIs")
(define *toc-lib-utilities-en*   "Library modules - Utilities")

;--------------------------------------
; type --> node のテーブル

; menu keyword ---> key変換器(関数・文法用)
(define gauche-menu-key-converter-fn
  (rxmatch-lambda
    ; (setter *)の処理 (重複している場合も含める)
    [#/^\s*\(setter\s+(\S+)\s*\).*$/ (_ k) k ]
    ; refなどの重複するエントリの処理
    [#/^\s*(\S+)\s*<[^>]+>.*$/ (_ k) k ]
    ; その他
    [else => identity ] ))

; menu keyword ---> key変換器(class用)
;<>記号をつけないクラス
;もあるかもしれないが、そのときはそのときに適宜対応する。$
(define gauche-menu-key-converter-cls
  (rxmatch-lambda
    ;
    ; 通常のエントリの処理
    [#/^\s*(\S+)\s*$/ (_ k) (format #f "<~a>" k) ]
    ; refなどの重複するエントリの処理
    [#/^\s*(\S+)\s*<[^>]+>.*$/ (_ k) (format #f "<~a>" k) ]
    ;
    ; その他
    [else => identity ] ))

; menu keyword ---> key変換器(その他)
(define gauche-menu-key-converter
  (rxmatch-lambda
    ; refなどの重複するエントリの処理
    [#/^\s*(\S+)\s*<[^>]+>.*$/ (_ k) k ]
    ; その他
    [else => identity ] ))

(define *info-node-names-source*
  (alist->hash-table
    `((function ,*index-node-source-function-jp* ,identity)
      (variable ,*index-node-source-variable-jp* ,identity)
      (class    ,*index-node-source-class-jp*    ,identity)
      (module   ,*index-node-source-module-jp*   ,identity) ) ) )

(define *info-node-names-jp*
  (alist->hash-table
    `((function ,*index-node-function-jp* ,gauche-menu-key-converter-fn )
      (variable ,*index-node-variable-jp* ,gauche-menu-key-converter )
      (class    ,*index-node-class-jp*    ,gauche-menu-key-converter-cls )
      (module   ,*index-node-module-jp*   ,gauche-menu-key-converter ) ) ) )
(define *info-node-names-en*
  (alist->hash-table
    `((function ,*index-node-function-en* ,gauche-menu-key-converter-fn )
      (variable ,*index-node-variable-en* ,gauche-menu-key-converter )
      (class    ,*index-node-class-en*    ,gauche-menu-key-converter-cls )
      (module   ,*index-node-module-en*   ,gauche-menu-key-converter ) ) ) )

(define *info-node-names-dev-en*
  (alist->hash-table
    `((function ,*index-node-dev-function-en* ,gauche-menu-key-converter )
      (type     ,*index-node-dev-type-en*     ,gauche-menu-key-converter )
      (variable ,*index-node-dev-variable-en* ,gauche-menu-key-converter ) ) ) )

(define *info-node-names-gl-en*
  (alist->hash-table
    `((function ,*index-node-gl-function-en* ,gauche-menu-key-converter-fn )
      (variable ,*index-node-gl-variable-en* ,gauche-menu-key-converter )
      (class    ,*index-node-gl-class-en*    ,gauche-menu-key-converter-cls )
      (module   ,*index-node-gl-module-en*   ,gauche-menu-key-converter ) ) ) )

;--------------------------------------
(define *info-src*
  (alist->hash-table
    `((default . refj) ; alias
      (dev . deve) ; alias
      (gl  . gle) ; alias
      ;;
      (ref   refj refe)
      (src  ,*source*           ,*info-node-names-source* )
      (refj ,*info-file-jp*     ,*info-node-names-jp* )
      (refe ,*info-file-en*     ,*info-node-names-en* )
      (deve ,*info-file-dev-en* ,*info-node-names-dev-en*)
      ;;
      (gle  ,*info-file-gl-en*  ,*info-node-names-gl-en*)
      ) ) )

;--------------------------------------------------------
; <info-node>のように見せるもの
(define-class <%node> []
  [(name    :init-keyword :name    :init-value "")
   (content :init-keyword :content :init-value "")
   ;;
   (file    :allocation :virtual :slot-ref (^[self] gauche-source ) )
   ;;
   (next    :init-keyword :next    :init-value #f)
   (prev    :init-keyword :prev    :init-value #f)
   (up      :init-keyowrd :up      :init-value #f)
   ] )
;--------------------------------------------------------
; info-index-node的な挙動をするmoduleファインダ
(define-class <gauche-module-finder> (<dictionary> <singleton-mixin>)
  [ (node    :init-value (make <%node> :name "*module*" ) )
    (*index* :init-value
            (lazy-dict
                (make-hash-table 'string=?)
                (^t
                  (dict-for-each (force *lazy-modules-table*)
                    (^[k v]
                      (dict-put! t k `(,v) ) ) ) ) ) )
    (index :allocation :virtual :slot-ref (^[self] ($ force $ ~ self '*index*) ) )
  ] )
(define-method initialize ((self <gauche-module-finder>) initargs)
  (next-method)
)
(define gauche-module-finder (instance-of <gauche-module-finder> ) ) ; initializeの定義後に書くこと

; dictionary protocol
(define-method dict-get     ((d <gauche-module-finder>) key :optional default)
  (dict-get (~ d 'index) key default ) )

(define-method dict-put!    ((d <gauche-module-finder>) key value)
  (dict-put! (~ d 'index) key value) )

(define-method dict-exists? ((d <gauche-module-finder>) key)
  (dict-exists? (~ d 'index) key ) )

(define-method dict-delete! ((d <gauche-module-finder>) key)
  (dict-delete! (~ d 'index) key ) )

(define-method dict-fold ((d <gauche-module-finder>) proc seed)
  (dict-fold (~ d 'index) proc seed))

(define-method call-with-iterator ((d <gauche-module-finder>) proc . keys)
  (apply call-with-iterator (~ d 'index) proc keys) )

; key ---> node-name
(define-method ref ((obj <gauche-module-finder>) (key <string>))
  (~ obj 'index key) )

;--------------------------------------------------------
; <cached-info-file>的な挙動をするソースブラウザ
(define-class <gauche-source> (<singleton-mixin>)
  [ (name :init-value *source* )
    (file :init-value #f )
    (key-converter-table :init-value #f )
    ;;
    (module   :init-value gauche-module-finder )
    (function :init-value #f )
    (class    :init-value #f )
    (macro    :init-value #f )
    (variable :init-value #f )
    ] )
(define-method initialize ((self <gauche-source>) initargs)
  ;#?= "initialize ((self <gauche-source>)"
  (next-method)
)
(define gauche-source (instance-of <gauche-source> ) ) ; initializeの定義後に書くこと

; refを定義する

; ソースの冒頭を取得する
(define (head-of-source path)
  (call-with-input-file path
    ($ (cut string-join <> "\n" 'suffix )
    $ generator->list $ gtake-while #/^\S/
    $ port->line-generator $) ) )

; node-name ---> node or #f
(define-method ref ((obj <gauche-source>) (key <string>))
  (rxmatch-case key
    ; 各種ファインダ
    [ #/\*(\S+)\*/ (_ slot-name) ($ ~ obj $ string->symbol slot-name) ]
    ; ファインダで求めた。ここにはpath名がくる
    [ else =>
      (^ (path)
        (make <%node> :name path
                      :content
                          (string-append
                            path "\n"
                            (head-of-source path) ) ) ) ]
  ) )


;--------------------------------------------------------
; <gauche-info-root>
; gaucheのinfoアクセスの元締め
(define-class <gauche-info-root> (<info-root> <singleton-mixin> ) () )
(define-method initialize ((root <gauche-info-root>) initargs)
  (next-method) )
(define gauche-info-root (instance-of <gauche-info-root> *info-src* ) )

(define-method get-info-paths ((root <gauche-info-root>))
  ;#?=root
  (let* ((syspath  (next-method))
         (instpath (list (gauche-config "--infodir")))
         (in-place (list "../doc")))
    ;#?=syspath
    ;#?=instpath
    ;#?=in-place
    (append syspath instpath in-place)))

; info-file-name ----> info
; ※ 一般の場合、key-converterテーブル参照は失敗するかもしれない
(define-method ref ((root <gauche-info-root>) (key <string>))
  ;#?= "ref ((root <gauche-info-root>) "
  (rxmatch-case key
    [ #/^\*source\*$/ ( _ ) gauche-source ]
    [ else (next-method) ] ) )

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

; deftp文字列の処理。適切なデータがないなら#f
; [ カテゴリ 名前 記述 元の文字列]を返す。
; predで名前判定する
; (<string> -> x) <string> ---> [<string> <string> <string> <string>]
(define (process-deftp-string pred s)
  (rxmatch-case s
      ; ( setter * )の処理
      [#/^\s+--\s([^:]+):\s*\(setter\s*(\S+)\s*\)\s*(.*)$/ ( org cat name disc)
        (if (pred name)
          `( ,cat ,name
             ,(rxmatch-case disc
               [#/^\s*$/ (_) #f ]
               [else => (cut string-append "!setter! " <> ) ] ) ,org )
          #f ) ]
      ; 通常の項目
      [#/^\s+--\s([^:]+):\s*(\S+)\s*(.*)$/ ( org cat name disc)
        (if (pred name)
          `( ,cat ,name
             ,(rxmatch-case disc
               [#/^\s*$/ (_) #f]
               [else => identity] ) ,org )
          #f) ]
      [else #f]
  ) )

; deftp文字列リストの処理。適切なデータがないなら#fを返す
; [ [ カテゴリ 名前 記述 元の文字列] ... ]を返す。
; predで名前判定する
; (<string> -> x) [<string>] ---> [[<string> <string> <string>] ... ]
(define (process-deftp-string-list pred sl)
  ($ (if-listfn$
        (pa$ filter-map (pa$ process-deftp-string pred) ) )
   ;$ tee print
   $ append-map
      (rxmatch-lambda
          ; ^cを展開する
          [#/^(\s+--\sMacro:\s+\^)c(\s+.*)$/ (_ h t)
            ($ map (cut string-append h <> t)
            $ cons "_" ; "^_" も追加する
            $ map ($ string $ integer->char $ + (char->integer #\a) $)  $ iota 26)]
          ; TAGvetorを展開する
          [#/^(.*)TAG(vector.*)$/ (_ h t)
            (map (cut string-append h <> t)
              '("s8" "u8" "s16" "u16" "s32" "u32" "s64" "u64" "f16" "f32" "f64")) ]
          [else => list ] )
      sl) )

; deftpと説明部を列挙する
; deftp = [ カテゴリ 名前 記述 元の文字列]
; [ 冒頭部(string list) [ [deftp(string-list) 説明(string list)] ... ] , node-name type info-index ]
(define-method info-deftp&body-generator ( (root <gauche-info-root>) pred . rest )
  ($ gfilter-map
     (match-lambda
       [(node-name content . rest )
          ($ (pack$ (^(h b) (if b (cons* h b node-name rest) #f ))
               ($ car $)
               ($ filter-map
                  (^x (if-let1 v (process-deftp-string-list pred (car x) )
                         (cons v (cdr x))
                         #f ) )
                $ (cut slices <> 2) $ cdr $) )
           $ (cut group-sequence <> :key ($ not $ #/^\s+--\s.*:/ $) )
           $ map (cut string-append <> "\n") ; tree->string で変換する用途のために行末に改行をつけておく
           $ (cut string-split <> #\nl) content )
       ])
    (apply info-content-generator root pred rest) ) )

(define (info-deftp&body-lseq . arg)
  ($ generator->lseq $ apply info-deftp&body-generator arg) )

; deftpの列挙
; deftp = [ カテゴリ 名前 記述 元の文字列]
; [ deftp(string list) , 説明(string list) , 冒頭部(string list) , node-name , type , info-index ]
(define-method info-deftp-generator ( (root <gauche-info-root>) pred . rest )
  ($ gconcatenate $ gmap (match-lambda
            [(head deftp&body . rest )
              ($ x->generator $ append-map
                (match-lambda
                  [(deftp body)
                    (map (cut cons* <> body head rest) deftp)])
                deftp&body) ])
    (apply info-deftp&body-generator root pred rest) ) )

(define-method info-deftp-lseq ( (root <gauche-info-root>) . arg)
  ($ generator->lseq $ apply info-deftp-generator root arg) )

; viewerでみるための文字列generatorを生成する

; 木構造になった、deftp見出しを巡回して、フィルタしながら変換
; predで名前判定する
(define (filter-map-nested-deftp$ pred)
  (if-listfn$ ($ filter-map
    (match-lambda
      ; 冒頭の文字列はそのまま残す
      [(? string? s) s]
      ; Node
      [( ( deftp-list . body ) . child-nodes)
        (let [[deftp-all      ($ (andfn$ (map$ (match-lambda [(_ _ _ org) org])) )
                                $ process-deftp-string-list (^_ #t) deftp-list)]
              [deftp-filtered ($ (andfn$ (map$ (match-lambda [(_ _ _ org) org])) )
                                $ process-deftp-string-list pred deftp-list)]
              [child-deftp    ((filter-map-nested-deftp$ pred) child-nodes)]]
          ;#?=deftp-all
          ;#?=deftp-filtered
          ;#?=child-deftp
          (cond
            [ (and (not deftp-filtered) (not child-deftp)) #f]
            [ (not child-deftp)    (append deftp-filtered body ) ]
            [ (not deftp-filtered) (append deftp-all      body child-deftp ) ]
            [ else (append deftp-filtered body child-deftp) ] ) )
        ] )
    $ ) ) )

; p = 見出し前の空白でグループ化した列で
; ( (n  deftp ... ) body (m deftp ) .... )
; これを、レベルを見て木構造にする。
(define (process-nested-deftp p)
  (cond
    [(null? p)   p]
    [(string? p) p]
    [(pair? p)
      (cond
        [(string? (car p)) (cons (car p) (process-nested-deftp (cdr p)) ) ]
        [(pair?   (car p))
          (receive (body d) (span string? (cdr p))
            (let [[n (caar p)]
                  [node (cons (cdar p) body ) ] ]
              (receive (h t) (span (any-pred string? ($ < n $ car $) ) d)
                (cons
                  (cons node (process-nested-deftp h))
                  (process-nested-deftp t) ) ) ) ) ]
        [else (errorf "??? ~a" (car p)) ] ) ]
    [else (errorf "??? ~a" p) ] ) )

(define (info-content-string pred content)
  ($ tree->string
  $ (filter-map-nested-deftp$ pred)
  $ process-nested-deftp
  ;$ tee-exit
  ;$ pretty-print
  $ map
        (match-lambda
          [ ( ( nn . s ) ... )
            (let1 n (car nn)
              (if n
                (cons n s)
                (string-concatenate s) ) ) ])
  $ (cut group-sequence <> :key car )
  $ map (pack$ cons
          (rxmatch-lambda [#/^(\s+)--\s.*:/ (_ h) (string-length h)] [else #f])
          (cut string-append <> "\n"))
  $ (cut string-split <> #\nl) content ) )

(define-method info-string-generator ( (root <gauche-info-root>) pred . rest)
  (gappend
    ; 関数・文法、変数 (funciton,variable)
    ($ gmap (match-lambda [( _ x . _ ) (info-content-string pred x ) ])
     $ apply info-content-generator root pred
        :type-filter (any-pred (pa$ eq? 'function) (pa$ eq? 'variable) )
        rest )
    ; class,module
    ($ gmap (match-lambda [( _ x . _ ) x] )
     $ apply info-content-generator root pred
        :type-filter (any-pred (pa$ eq? 'class) (pa$ eq? 'module) )
        rest )
    ; module ( source )
    ($ gmap (match-lambda [( _ x . _ ) x] )
     $ info-content-generator root pred
        :type-filter (any-pred (pa$ eq? 'module) )
        :tag 'src)
  ) )

(define-method info-string-lseq ( (root <gauche-info-root>) pred . rest)
  ($ generator->lseq $ apply info-string-generator root pred rest) )

(define (info-node-function-jp ) (~ gauche-info-root *info-file-jp* *index-node-function-jp*))
(define (info-node-variable-jp ) (~ gauche-info-root *info-file-jp* *index-node-variable-jp*))
(define (info-node-class-jp )    (~ gauche-info-root *info-file-jp* *index-node-class-jp*   ))
(define (info-node-module-jp )   (~ gauche-info-root *info-file-jp* *index-node-module-jp*  ))

(define (info-node-function-en ) (~ gauche-info-root *info-file-en* *index-node-function-en*))
(define (info-node-variable-en ) (~ gauche-info-root *info-file-en* *index-node-variable-en*))
(define (info-node-class-en )    (~ gauche-info-root *info-file-en* *index-node-class-en*   ))
(define (info-node-module-en )   (~ gauche-info-root *info-file-en* *index-node-module-en*  ))

#!/usr/bin/env gosh
; /* -%- lang:scheme indent-width: 2; use-tabs: no; strip: yes -%-

(use gauche.parseopt)
(use textj.view-infoj)

(define (main args)
  (let-args (cdr args)
    [[ofni-mode       "ofni"]
     [ofni-mode-rx    "ofnix"]
     [module-mode     "m"]
     [module-mode-rx  "mx"]
     [grep-mode       "g"]
     [grep-mode-rx    "gx"]
     [else [opt . _ ] (print "不明なオプション : " opt) (exit) ]
     . args]
    (cond
      [(null? args) (error "キーワードを指定すること")]
      [ ofni-mode       (ofni       (car args))]
      [ ofni-mode-rx    (ofni       ($ string->regexp $ car args))]
      [ module-mode     (modulegrep (car args))]
      [ module-mode-rx  (modulegrep ($ string->regexp $ car args))]
      [ grep-mode       (infogrep   (car args))]
      [ grep-mode-rx    (infogrep   ($ string->regexp $ car args))]
      [ else            (infoj      (car args))] )
  ) 0 )

(※ gauche-classes、gauche-modulesのコードはGauche:モジュールの列挙にあります。)

Tag: gauche.interactive.info

Topics
Sponsored Links
Search
Recent Changes
More ...
Last modified : 2013/04/23 22:23:39 UTC
WiLiKi 0.8.3 running on Gauche 0.9.15