commander-s/scheme/console.scm

(define-record-type console :console
  (really-make-console pty-in pty-out 
		       pause-channel resume-channel 
		       window terminal-buffer)
  console?
  (pty-in console-pty-in)
  (pty-out console-pty-out)
  (pause-channel console-pause-channel)
  (resume-channel console-resume-channel)
  (window console-window)
  (terminal-buffer console-terminal-buffer))

(define (make-console pty-in pty-out window terminal-buffer)
  (let ((pause-channel (make-channel))
	(resume-channel (make-channel)))
    (spawn-console-loop
     pause-channel resume-channel window terminal-buffer
     (make-channel-for-pty-out pty-in))
    (really-make-console 
     pty-in pty-out pause-channel resume-channel
     window terminal-buffer)))

(define (make-channel-for-pty-out pty)
  (let ((channel (make-channel)))
    (spawn
     (lambda ()
       (debug-message "make-channel-for-pty-out " pty)
       (let lp ((c (read-char pty)))
	 (if (not (eof-object? c))
	     (begin
	       (send channel c)
	       (lp (read-char pty)))))))
    channel))

(define (spawn-console-loop 
	 pause-channel resume-channel 
	 window terminal-buffer pty-channel)
  (spawn 
   (lambda ()
     (let lp ((paint? #f))
       (select
	(wrap (receive-rv pause-channel)
	      (lambda (ignore)
		(lp #f)))
	(wrap (receive-rv resume-channel)
	      (lambda (ignore)
		(lp #t)))
	(wrap (receive-rv pty-channel)
	      (lambda (char)
		(cond
		 ((eof-object? char)
		  (lp paint?))
		 (else
		  (terminal-buffer-add-char terminal-buffer char)
		  (if paint?
		      (begin
			(curses-paint-terminal-buffer 
			 terminal-buffer window)
			(wrefresh window)))
		  (lp paint?))))))))))

(define (pause-console-output console)
  (debug-message "pause-console-output")
  (send (console-pause-channel console) 'ignore))

(define (resume-console-output console)
  (debug-message "resume-console-output")
  (send (console-resume-channel console) 'ignore))

(define (view-console console)
  (debug-message "view-console " console)
  (curses-paint-terminal-buffer/complete
   (console-terminal-buffer console)
   (console-window console))
  (resume-console-output console)
  (spawn
   (lambda ()
     (sync
      (wrap (result-buffer-other-object-has-focus-rv)
	    (lambda (ack-channel)
	      (pause-console-output console)
	      (send ack-channel 'ignore)))))))

(define (make-console-viewer console buffer)
  (lambda (message)
    (case message
      ((paint)
       (lambda (self win buffer have-focus?)
	 (view-console console)))
      (else 
       (lambda (self . more)
	 self)))))

(register-plugin!
 (make-view-plugin make-console-viewer console?))