gpsh

#!/usr/bin/env gosh
;; -*-Scheme-*-
;;;
;;; gpsh or gosh-pseudo-session
;;;
;;; Usage: gpsh file.scm
;;;
;;;                 written by skimu@mac.com
;;;
(use gauche.vport)

(define (open-mirroring-input port dest-port)
  (let ((mirror-port (make <virtual-input-port>)))
    (define (getb)
      (let ((c (read-byte port)))
        (if (eof-object? c)
            c
            (begin
              (write-byte c dest-port)
              c))))
    (define (getc)
      (let ((c (read-char port)))
        (if (eof-object? c)
            c
            (begin
              (display c dest-port)
              c))))
    (define (gets n)
      (let ((str (read-block n port)))
        (if (eof-object? str)
            str
            (begin
              (display str dest-port)
              str))))
    (define (ready char?)
      (if char?
          (char-ready? port)
          (byte-ready? port)))
    (define (seek offset whence)
      (port-seek port offset whence))

    (slot-set! mirror-port 'getb getb)
    (slot-set! mirror-port 'getc getc)
    (slot-set! mirror-port 'gets gets)
    (slot-set! mirror-port 'ready ready)
    (slot-set! mirror-port 'seek seek)
    mirror-port))

(define (open-output-with-prefix dest)
  (let ((port (make <virtual-output-port>)))

    (define need-prefix? #t)

    (define (putb b)
      (if need-prefix?
        (display ";|" dest))
      (set! need-prefix? #f)
      (write-byte b dest)
      (if (= b (char->integer #\newline))
          (set! need-prefix? #t)))

    (define (putc ch)
      (if need-prefix?
          (display ";|" dest))
      (set! need-prefix? #f)
      (write-char ch dest)
      (if (char=? ch #\newline)
          (set! need-prefix? #t)))

    (define (flushf)
      (flush dest))

    (slot-set! port 'putb putb)
    (slot-set! port 'putc putc)
    (slot-set! port 'flush flushf)
    port))

(define (pseudo-session src)

  (let* ((real-out (current-output-port))
         (in  (open-mirroring-input src real-out))
         (out (open-output-with-prefix real-out)))

    (define (print-with-prefix . vals)
      (display ";=> " real-out)
      (for-each (lambda (x)
                  (write x real-out)
                  (display " " real-out))
                vals)
      (flush out))

    (define (reader-with-trick)
      (begin0 (read in)
              (newline real-out)))

    (define (prompter) #t)

    (unwind-protect
        (with-output-to-port out
          (lambda ()
            (read-eval-print-loop
             reader-with-trick
             #f
             print-with-prefix
             prompter)))
      (unless (port-closed? in)  (close-input-port  in))
      (unless (port-closed? out) (close-output-port out))
      )))

(define (pseudo-session-with-file scmfile)
  (call-with-input-file scmfile pseudo-session))

(define (main args)
  (if (= (length args) 2)
      (pseudo-session-with-file (cadr args))
      (errorf "Usage: ~a file.scm" (car args)))
  0)

;;; EOF