gauche.vport の活用 : mirroring port と transcript-on

transcript-on.scm

;;;
;;;   gauche.vport の活用 : mirroring port と transcript-on
;;                         そして column port
;;;
;;;                                         [email protected]
;;;                                           Feb 4, 2016
;;;
;;;   transcript-on2 が期待される動作をしないのを修正して、
;;;   ついでに現在のカラムをとってこれる column port を追加。
;;;
;;;                                           Feb 7, 2016
;;;
(use gauche.vport)

;;   1. mirroring port
;;
;;　　mirroring input port とはプログラムがあるポートからデータを
;;   読み出すたびに、自動的にそのデータを(あらかじめ指定しておいた)
;;   別のポートに書き出すポートです。
;;   mirroring output port は同様にプログラムがそのポートに
;;   何かデータを書き込むたびに、自動的にそのデータを(あらかじめ
;;   指定しておいた)別のポートに書き出すポートです。
;;
;;   主にデバッグ時に便利な機能です。
;;
;;   まずは
;;
;;     (with-input-from-string/mirrorin-to-port str output-port thunk)
;;
;;   を使ってみましょう。
;;
;;   この関数は文字列ポートを str から作ってそれを入力ポートとして
;;   thunk を呼び出します。 そして thunk が文字を読み込むたびに、
;;   その文字を output-port へ書き出します。
;;
;; 　 次の例では "(((a)))\n" を read で読みます。
;;   (((a))) は正しい S-式なので問題なく読めるはずです。
#|
(use ggc.port.mirroring)

(with-input-from-string/mirroring-to-port
    "(((a)))\n"　　　　　　　　; この文字列から入力ポートを作って
    (current-output-port)    ; そのポートから何かを読み出すたびに (current-output-port) にも送られます。
  (lambda ()
    (with-error-to-port (current-output-port)
      (lambda ()
        (let ((data (read)))
          ;;　read は (((a))) まで読んで帰ってくる。
          (display "newline after this->")
          ;; 次の read-char が文字列の最後尾の '\n' を読み込んでそれが (current-output-port) へ
          (read-char)
          data)))))
;|(((a)))newline after this->
;=> (((a)))

;; ここで ;| は画面に表示されるものを示し、　;=> は式の値を示してます。
;; つまり、(((a)))newline after this-> が表示され、 次の行の (((a))) が
;; この式の返り値です。
;;
;;  次に括弧の対応が悪い "(((a)])\n" を読んでみます。
;;  read はエラーを投げるはずです。
;;
(with-input-from-string/mirroring-to-port
        "(((a)])\n" (current-output-port)
  (lambda ()
    (with-error-to-port (current-output-port)
      (lambda ()
        (let ((data (read)))
          (display "newline after this->")
          (read-char)
          data)))))
;|(((a)]*** READ-ERROR: Read error at "??":line 1: extra close parenthesis `]'
;|Stack Trace:
;|_______________________________________
;|  0  (read)
;|        [unknown location]
;|  1  (proc p)
;|        at "/usr/local/share/gauche-0.9/site/lib/ggc/port/mirroring.scm":69
;|  2  (with-output-to-port out (lambda () (read-eval-print-loop rea ...
;|        at "/Users/skimu/bin/scripts/gpsh":63
;|  3  (pseudo-session-with-file (cadr args))
;|        at "/Users/skimu/bin/scripts/gpsh":79
;;
;; このように ']' を読んだところで read が error を投げる様子がわかります。
;;
;; データやログファイルを読み込んで処理するプログラムは大抵
;;
;;    (with-input-from-file filename
;;      (lambda ()
;;        (繰り返し
;;            読み込み
;;            処理)))
;;
;; みたいな構造になってますが何か問題のあった時にこれを
;;
;;    (with-input-from-file/mirroring-to-port filename (current-output-port)
;;      (lambda ()
;;        (繰り返し
;;            読み込み
;;            処理)))
;;
;; とするだけで、問題が起きる前に処理が読み込まれた分だけ (current-output-port) 
;; に書き込まれるので、それをみると大抵問題の見当がつきます。
;;
|#

;;   他にも
;;       with-input-from-port/mirrorin-to-port
;;       with-input-from-port/mirrorin-to-file
;;       with-input-from-file/mirrorin-to-file ...
;;  などなど、いろんな組み合わせが ggc.port.mirroring には用意されてます。
;;
;;  https://github.com/karme/gauchegc/tree/master/port.mirroring
;;
;;   mirroring ポートは gauche.vport を使ってこんな風に実装しています。
;;
(define (open-mirroring-input in dest-port)
  (let ((mi (make <virtual-input-port>)))
    (define (getb)
      (let ((c (read-byte in)))
        (cond ((eof-object? c) c)
              (else
               (write-byte c dest-port)
               c))))
    (define (getc)
      (let ((c (read-char in)))
        (cond ((eof-object? c) c)
              (else
               (write-char c dest-port)
               c))))
    (define (gets n)
      (let ((str (read-block n in)))
        (cond ((eof-object? str) str)
              (else
               (display str dest-port)
               str))))
    (define (ready char?)
      (if char?
        (char-ready? in)
        (byte-ready? in)))
    (define (seek offset whence)
      (port-seek in offset whence))
    (slot-set! mi 'getb getb)
    (slot-set! mi 'getc getc)
    (slot-set! mi 'gets gets)
    (slot-set! mi 'ready ready)
    (slot-set! mi 'seek seek)
    mi))

(define (open-mirroring-output out dest-port)
  (let ((mo (make <virtual-output-port>)))
    (define (putb b)
      (write-byte b dest-port)
      (write-byte b out))
    (define (putc c)
      (write-char c dest-port)
      (write-char c out))
    (define (puts str)
      (display str dest-port)
      (display str out))
    (define (flus)
      (flush dest-port)
      (flush out))
    (define (seek offset whence)
      (port-seek out offset whence))
    (slot-set! mo 'putb  putb)
    (slot-set! mo 'putc  putc)
    (slot-set! mo 'puts  puts)
    (slot-set! mo 'flush flus)
    (slot-set! mo 'seek  seek)
    mo))

;;
;;　 transcript-on はこれらを使ってこんな風にかけます。
;;
(define (transcript-on file)
  (let* ((dest (open-output-file file))
         (mi   (open-mirroring-input  (current-input-port)  dest))
         (mo   (open-mirroring-output (current-output-port) dest)))
    (unwind-protect
        (with-ports mi mo mo
                    (lambda ()
                      (read-eval-print-loop #f #f #f
                                            (lambda ()
                                              (display #"[~|file|]> ")
                                              (flush)))))
      (close-port mi)
      (close-port mo)
      (close-port dest))))

;;
;; 上の transcript-on を終了するには C-d で reader に EOF を送ります。
;; やっぱり (transcript-off) で終わりたいという向きには
;; reader に手を加えて
;;
(define (transcript-on2 file)
  (let* ((dest (open-output-file file))
         (mi   (open-mirroring-input  (current-input-port)  dest))
         (mo   (open-mirroring-output (current-output-port) dest)))
    (unwind-protect
        (with-ports mi mo mo
                    (lambda ()
                      (read-eval-print-loop
                       (lambda ()
                         (let ((x (read)))
                           (if (equal?  x '(transcript-off))
                             (eof-object)
                             x)))
                       #f #f
                       (lambda ()
                         (display #"[~|file|]> ")
                         (flush)))))
      (close-port mo)
      (close-port mi)
      (close-port dest))))

;;
;; こんな感じでどうでしょう？.... ダメですね。
;;
;; read は空白改行を読み飛ばしてから式を読み出し、それが終わったら
;; それに続く空白改行を残したまま戻ってきてしまうので
;; repl の入力にした式の後に続く改行は次の read まで読まれせん。
;; 最初の transcript-on がうまく行ったのはデフォルトの reader は
;; read で式を読み込んだ後の空白改行がバッファに残っていたら
;; それらを読んでから戻るようになっているためでした。
;; 修正したバージョンを ggc に入れておきました。
;; 
;;  https://github.com/karme/gauchegc/blob/master/transcript-on/transcript-on.scm
;;
;;
;;
;;   便利な関数群はこんな感じになってます。
;;
(define (call-with-mirroring-input port dest-port proc)
  (let1 p (open-mirroring-input port dest-port)
    (unwind-protect (proc p)
      (unless (port-closed? p)
        (close-port p)))))

(define (with-input-from-port/mirroring-to-port port dest-port thunk)
  (call-with-mirroring-input port dest-port
    (lambda (p)
      (with-input-from-port p thunk))))

(define (with-input-from-port/mirroring-to-file port dest-file thunk)
  (call-with-output-file dest-file
    (lambda (dest-port)
      (with-input-from-port/mirroring-to-port
          port dest-port
        thunk))))

(define (with-input-from-string/mirroring-to-port str dest-port thunk)
  (call-with-input-string str
    (lambda (port)
      (with-input-from-port/mirroring-to-port
          port dest-port
        thunk))))

;;  2. column ポート
;;
;;  Gauche のポートは現在の行番号は (port-current-line port) でとってこれますが、
;;  カラム(改行からの文字数)はサポートされてません。
;;  ファイル読み込み中のエラーを報告するのに行番号と合わせてカラムも表示しておくと
;;  エディタでそのファイルの問題の位置にピンポイントで移動できるので便利です。
;;  
;;  そこで virtual-input-port に必要なスロットを追加してポートから
;;  文字を読むたびに行番号とカラムを計算して保持しておくポートを作ってけば
;;  読み込みプログラムで個別に対応するより便利です。
;;
(define-class <column-port> (<virtual-input-port>)
  (src name line column))

(define (open-column-port src-port)
  (let ((port (make  <column-port>)))
    (define (getc)
      (let ((c (read-char src-port)))
        (cond ((eof-object? c) c)
              ((char=? #\nl c)
               (inc! (~ port'line))
               (set! (~ port'column) 0)
               c)
              (else
               (inc! (~ port'column))
               c))))
    (define (ready char?)
      (if char?
        (char-ready? src-port)
        (byte-ready? src-port)))
    (slot-set! port 'src  src-port)
    (slot-set! port 'name (port-name src-port))
    (slot-set! port 'line
               (let ((x (port-current-line src-port)))
                 (if (negative? x) 1 x)))
    (slot-set! port 'column 0)
    (slot-set! port 'getc   getc)
    (slot-set! port 'ready  ready)
    port))

;;
;; この例では行(line)も計算してますが、行に関しては<virtual-input-port>でも
;; 面倒みてるので省いても構いません。
;;
;; カラムを取り出す port-current-column はこんな感じになります。
;;
(define-method port-current-column ((port <column-port>))
  (slot-ref port'column))

(define-method port-current-column ((port <port>))
  #f)

;;
;; こうしておけばスピード重視の時は通常のファイルポートを使って
;; カラムの取得は諦め、デバッグ時には <column-port> を使って
;; 多少のスピードを犠牲にして利便性を取ることができます。
;;
;; 便利な関数群は mirroring port と同じバターンで
;;
(define (call-with-input-file/column file proc)
  (let*  ((s (open-input-file  file))
          (p (open-column-port s)))
    (unwind-protect (proc p)
      (unless (port-closed? p) (close-port p))
      (unless (port-closed? s) (close-port s)))))

(define (with-input-from-file/column file thunk)
  (call-with-input-file/column file
    (lambda (p)
      (with-input-from-port p thunk))))

;; となります。
;; モジュールにしたのを ggc.port.column に入れときました。
;;
;;  https://github.com/karme/gauchegc/tree/master/port.column
;;
;;; EOF