commander-s/scheme/console.scm

92 lines
2.4 KiB
Scheme
Raw Normal View History

(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? #t))
(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)
(send (console-pause-channel console) 'ignore))
(define (resume-console-output console)
(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 (ignore)
(pause-console-output console)))))))
(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?))