scsh-conservatory
/
commander-s
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

A first (buggy) version with a virtual console

This commit is contained in:
eknauel 2005-06-07 18:24:05 +00:00
parent 8ae60787a7
commit 7d0c566c0b
8 changed files with 798 additions and 235 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

91
scheme/console.scm Normal file
View File

@ -0,0 +1,91 @@
(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))
(debug-message "spawn-console-loop " paint?)
(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?
(curses-paint-terminal-buffer
terminal-buffer 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?))

82
scheme/job-viewer.scm
View File

@ -105,3 +105,85 @@
(register-plugin! (register-plugin!
(make-view-plugin make-joblist-viewer list-of-jobs?)) (make-view-plugin make-joblist-viewer list-of-jobs?))
;;; viewer for a single job viewer
(define (make-job-viewer job buffer)
(let ((select-list #f)
(num-cols
(- (result-buffer-num-cols buffer) 1)))
(define (make-job-select-list job)
(make-select-list
(map
(lambda (args)
(make-unmarked-element
(car args) #f
(cut-to-size
num-cols
(apply string-append
(append
(list (fill-up-string 15 (cadr args)))
(cddr args))))))
(list
(list (job-name->string (job-name job))
"name:" (job-name->string (job-name job)))
(list (if (job-end-time job)
(number->string (job-status job)) #f)
"status:"
(if (job-end-time job)
(number->string (job-status job))
"-"))
(list (job-start-time job)
"start:"
(short-date (job-start-time job)))
(list (job-end-time job)
"end:"
(if (job-end-time job)
(short-date (job-end-time job))
"-"))
(list #f "run status:"
(symbol->string (job-run-status job)))
(list (job-console job)
"<View Console>" "")))
(- (result-buffer-num-lines buffer) 1)))
(define (handle-key-press self key control-x-pressed?)
(cond
((= key (char->ascii #\g))
(set! select-list (make-job-select-list job)))
((= key (char->ascii #\newline))
(select-list-selected-entry select-list))
(else
(set! select-list
(select-list-handle-key-press select-list key))))
self)
(set! select-list (make-job-select-list job))
(lambda (message)
(case message
((paint)
(lambda (self win buffer have-focus?)
(mvwaddstr
win 0 0
(cut-to-size
num-cols (string-append "Viewing job: "
(job-name->string (job-name job)))))
(paint-selection-list-at
select-list 0 1 win buffer have-focus?)))
((key-press) handle-key-press)
((get-selection)
(make-get-focus-object-method select-list))
((get-focus-object)
(make-get-focus-object-method select-list))
(else
(error "job viewer unknown message" message))))))
(register-plugin!
(make-view-plugin make-job-viewer job?))

42
scheme/job.scm
View File

@ -1,12 +1,10 @@
(define-record-type job :job (define-record-type job :job
(really-make-job name pty-in pty-out proc (really-make-job name console
status proc status
start-time end-time start-time end-time run-status)
run-status)
job? job?
(name job-name) (name job-name)
(pty-in job-pty-in) (console job-console)
(pty-out job-pty-out)
(proc job-proc) (proc job-proc)
(status really-job-status) (status really-job-status)
(start-time job-start-time) (start-time job-start-time)
@ -17,9 +15,13 @@
(lambda (r) (lambda (r)
`(job ,(job-name r) ,(job-run-status r)))) `(job ,(job-name r) ,(job-run-status r))))
(define (make-job name pty-in pty-out proc) (define (make-job name pty-in pty-out terminal-buffer proc)
(let ((job (really-make-job (let ((job (really-make-job
name pty-in pty-out proc (make-placeholder) name
(make-console pty-in pty-out
(app-window-curses-win (result-window))
terminal-buffer)
proc (make-placeholder)
(date) #f 'running))) (date) #f 'running)))
(spawn-job-status-surveillant job) (spawn-job-status-surveillant job)
(add-job! job) (add-job! job)
@ -62,6 +64,12 @@
(define (continue-job job) (define (continue-job job)
(signal-process-group signal/cont job)) (signal-process-group signal/cont job))
(define (pause-job-output job)
(pause-console-output (job-console job)))
(define (resume-job-output job)
(resume-console-output (job-console job)))
;; channels for communicating with the joblist surveillant ;; channels for communicating with the joblist surveillant
(define add-job-channel (define add-job-channel
@ -70,6 +78,9 @@
(define get-job-list-channel (define get-job-list-channel
(make-channel)) (make-channel))
(define clear-ready-jobs-channel
(make-channel))
(define (add-job! job) (define (add-job! job)
(send add-job-channel job)) (send add-job-channel job))
@ -83,6 +94,9 @@
(send get-job-list-channel (cons 'ready answer-channel)) (send get-job-list-channel (cons 'ready answer-channel))
(receive answer-channel))) (receive answer-channel)))
(define (clear-ready-jobs!)
(send clear-ready-jobs-channel 'ignored))
(define (jobs-with-new-output) (define (jobs-with-new-output)
(let ((answer-channel (make-channel))) (let ((answer-channel (make-channel)))
(send get-job-list-channel (cons 'new-output answer-channel)) (send get-job-list-channel (cons 'new-output answer-channel))
@ -119,6 +133,10 @@
(lambda (new-job) (lambda (new-job)
(lp (cons new-job running) (lp (cons new-job running)
ready new-output waiting-for-input #t))) ready new-output waiting-for-input #t)))
(wrap (receive-rv clear-ready-jobs-channel)
(lambda (ignore)
(lp running '() new-output waiting-for-input #t)))
(wrap (receive-rv get-job-list-channel) (wrap (receive-rv get-job-list-channel)
(lambda (state.channel) (lambda (state.channel)
@ -155,7 +173,7 @@
(lambda args (lambda args
(display args)))) (display args))))
(define-syntax run-as-background-job (define-syntax run/bg
(syntax-rules () (syntax-rules ()
((_ epf) ((_ epf)
(call-with-values (call-with-values
@ -164,6 +182,10 @@
(lambda () (lambda ()
(exec-epf epf)))) (exec-epf epf))))
(lambda (proc pty-in pty-out tty-name) (lambda (proc pty-in pty-out tty-name)
(make-job (quote epf) pty-in pty-out proc)))))) (make-job (quote epf) pty-in pty-out
(make-terminal-buffer
(- (result-buffer-num-cols (result-buffer)) 1)
(- (result-buffer-num-lines (result-buffer)) 1))
proc))))))
;;; EOF ;;; EOF

314
scheme/nuit-engine.scm
View File

@ -1,5 +1,3 @@
;; ,load /home/demattia/studium/studienarbeit/scsh-nuit/scheme/nuit-engine.scm
(define-syntax when (define-syntax when
(syntax-rules () (syntax-rules ()
((_ ?test ?do-this ...) ((_ ?test ?do-this ...)
@ -16,83 +14,6 @@
(release-lock lock) (release-lock lock)
val))))) val)))))
;;This is the "heart" of NUIT.
;;In a central loop the program waits for input (with wgetch).
;;In the upper buffer simply the functionalities of scsh-ncurses:
;;input-buffer are used.
;;The lower window is meant to be used more flexible. Depending on
;;the active command the key-inputs are routed to the correct receiver,
;;where one can specify how to react.
;;*************************************************************************
;;State
(define-record-type app-window :app-window
(make-app-window x y width height curses-win)
app-window?
(x app-window-x)
(y app-window-y)
(width app-window-width)
(height app-window-height)
(curses-win app-window-curses-win set-app-window-curses-win!))
(define-record-discloser :app-window
(lambda (rec)
`(app-window
(x ,(app-window-x rec)) (y ,(app-window-y rec))
(w ,(app-window-width rec)) (h ,(app-window-height rec)))))
(define bar-1 #f)
(define active-command-window #f)
(define command-frame-window #f)
(define command-window #f)
(define result-window #f)
(define result-frame-window #f)
(define executable-completions-lock (make-lock))
(define executable-completions #f)
(define paint-lock (make-lock))
(define key-control-x 24)
(define key-o 111)
(define key-tab 9)
;;state of the upper window (Command-Window)
(define command-buffer
(make-buffer '("Welcome to the scsh-ncurses-ui!" "")
2 2 2 1 1
0 0
#t 1))
;;state of the lower window (Result-Window)
;;----------------------------
;;Text
(define result-buffer
(make-result-buffer 0 0 0 0
#f #f ; set in INIT-WINDOWS
'() '()))
;;miscelaneous state
;;-------------------
(define *focus-buffer* 'command-buffer)
(define (focus-on-command-buffer?)
(eq? *focus-buffer* 'command-buffer))
(define (focus-command-buffer!)
(set! *focus-buffer* 'command-buffer))
(define (focus-on-result-buffer?)
(eq? *focus-buffer* 'result-buffer))
(define (focus-result-buffer!)
(set! *focus-buffer* 'result-buffer))
;; mode of the command buffer ;; mode of the command buffer
(define *command-buffer-mode* 'scheme) (define *command-buffer-mode* 'scheme)
@ -108,6 +29,15 @@
(define (enter-command-mode!) (define (enter-command-mode!)
(set! *command-buffer-mode* 'command)) (set! *command-buffer-mode* 'command))
(define paint-lock (make-lock))
(define executable-completions-lock (make-lock))
(define executable-completions #f)
(define key-control-x 24)
(define key-o 111)
(define key-tab 9)
;; History ;; History
(define history-pos 0) (define history-pos 0)
@ -214,7 +144,7 @@
(refresh-result-window)) (refresh-result-window))
(else (else
(focus-command-buffer!) (focus-command-buffer!)
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-command-window)))) (refresh-command-window))))
(define (toggle-command/scheme-mode) (define (toggle-command/scheme-mode)
@ -225,11 +155,11 @@
(enter-command-mode!))) (enter-command-mode!)))
(paint-command-frame-window) (paint-command-frame-window)
(paint-command-window-contents) (paint-command-window-contents)
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-command-window)) (refresh-command-window))
(define (handle-return-key) (define (handle-return-key)
(let ((command-line (cadr (reverse (buffer-text command-buffer))))) (let ((command-line (cadr (reverse (buffer-text (command-buffer))))))
(debug-message "command-line " command-line) (debug-message "command-line " command-line)
(cond (cond
((string=? command-line "") ((string=? command-line "")
@ -262,10 +192,11 @@
(make-history-entry command args viewer))) (make-history-entry command args viewer)))
;; FIXME, use insert here ;; FIXME, use insert here
(append-to-history! new-entry) (append-to-history! new-entry)
(signal-result-buffer-object-change)
(obtain-lock paint-lock) (obtain-lock paint-lock)
(paint-result-window new-entry) (paint-result-window new-entry)
(refresh-result-window) (refresh-result-window)
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-command-window) (refresh-command-window)
(release-lock paint-lock))) (release-lock paint-lock)))
@ -280,10 +211,11 @@
(make-history-entry command args viewer))) (make-history-entry command args viewer)))
;; #### shouldn't we use some kind of insertion here? ;; #### shouldn't we use some kind of insertion here?
(append-to-history! new-entry) (append-to-history! new-entry)
(signal-result-buffer-object-change)
(obtain-lock paint-lock) (obtain-lock paint-lock)
(paint-result-window new-entry) (paint-result-window new-entry)
(refresh-result-window) (refresh-result-window)
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-command-window) (refresh-command-window)
(release-lock paint-lock)))) (release-lock paint-lock))))
@ -295,9 +227,9 @@
(send (current-viewer) (send (current-viewer)
'get-selection 'get-selection
(command-buffer-in-scheme-mode?) (focus-table))) (command-buffer-in-scheme-mode?) (focus-table)))
(print-command-buffer (app-window-curses-win command-window) (print-command-buffer (app-window-curses-win (command-window))
command-buffer) (command-buffer))
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-command-window)) (refresh-command-window))
(define (paste-focus-object/refresh viewer) (define (paste-focus-object/refresh viewer)
@ -308,15 +240,18 @@
(command-buffer-in-scheme-mode?) (command-buffer-in-scheme-mode?)
(focus-table)) (focus-table))
(send (current-viewer) 'get-focus-object (focus-table)))) (send (current-viewer) 'get-focus-object (focus-table))))
(print-command-buffer (app-window-curses-win command-window) (print-command-buffer (app-window-curses-win (command-window))
command-buffer) (command-buffer))
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-command-window)) (refresh-command-window))
;; handle input ;; handle input
(define (run) (define (run)
(init-screen)
(init-windows!) (init-windows!)
(clear)
(init-executables-completion-set!) (init-executables-completion-set!)
;; init joblist ;; init joblist
@ -329,8 +264,8 @@
(paint-command-frame-window) (paint-command-frame-window)
(paint-job-status-list stats) (paint-job-status-list stats)
(paint-command-window-contents) (paint-command-window-contents)
(wrefresh (app-window-curses-win command-frame-window)) (wrefresh (app-window-curses-win (command-frame-window)))
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-command-window) (refresh-command-window)
(release-lock paint-lock) (release-lock paint-lock)
(lp (cml-receive statistics-channel)))))) (lp (cml-receive statistics-channel))))))
@ -368,7 +303,7 @@
((and (focus-on-command-buffer?) ((and (focus-on-command-buffer?)
(= ch key-tab)) (= ch key-tab))
(let ((maybe-selector (let ((maybe-selector
(offer-completions (last (buffer-text command-buffer))))) (offer-completions (last (buffer-text (command-buffer))))))
(loop (wait-for-input) #f maybe-selector))) (loop (wait-for-input) #f maybe-selector)))
;; F7 toggle scheme-mode / command-mode (FIXME: find a better key) ;; F7 toggle scheme-mode / command-mode (FIXME: find a better key)
@ -422,6 +357,7 @@
(obtain-lock paint-lock) (obtain-lock paint-lock)
(when (current-history-item) (when (current-history-item)
(paint-active-command-window) (paint-active-command-window)
(signal-result-buffer-object-change)
(paint-result-window (entry-data (current-history-item)))) (paint-result-window (entry-data (current-history-item))))
(refresh-result-window) (refresh-result-window)
(release-lock paint-lock) (release-lock paint-lock)
@ -433,18 +369,19 @@
(obtain-lock paint-lock) (obtain-lock paint-lock)
(when (current-history-item) (when (current-history-item)
(paint-active-command-window) (paint-active-command-window)
(signal-result-buffer-object-change)
(paint-result-window (entry-data (current-history-item)))) (paint-result-window (entry-data (current-history-item))))
(refresh-result-window) (refresh-result-window)
(release-lock paint-lock) (release-lock paint-lock)
(loop (wait-for-input) c-x-pressed? #f)) (loop (wait-for-input) c-x-pressed? #f))
((and (focus-on-command-buffer?) (= ch 10)) ((and (focus-on-command-buffer?) (= ch 10))
(input command-buffer ch) (input (command-buffer) ch)
(obtain-lock paint-lock) (obtain-lock paint-lock)
(werase (app-window-curses-win command-window)) (werase (app-window-curses-win (command-window)))
(print-command-buffer (app-window-curses-win command-window) (print-command-buffer (app-window-curses-win (command-window))
command-buffer) (command-buffer))
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-command-window) (refresh-command-window)
(release-lock paint-lock) (release-lock paint-lock)
(handle-return-key) (handle-return-key)
@ -459,78 +396,21 @@
'key-press ch c-x-pressed?)) 'key-press ch c-x-pressed?))
(obtain-lock paint-lock) (obtain-lock paint-lock)
(paint-result-window (entry-data (current-history-item))) (paint-result-window (entry-data (current-history-item)))
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-result-window) (refresh-result-window)
(release-lock paint-lock)) (release-lock paint-lock))
(loop (wait-for-input) #f #f)) (loop (wait-for-input) #f #f))
(else (else
(input command-buffer ch) (input (command-buffer) ch)
(obtain-lock paint-lock) (obtain-lock paint-lock)
(werase (app-window-curses-win command-window)) (werase (app-window-curses-win (command-window)))
(print-command-buffer (app-window-curses-win command-window) (print-command-buffer (app-window-curses-win (command-window))
command-buffer) (command-buffer))
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-command-window) (refresh-command-window)
(release-lock paint-lock) (release-lock paint-lock)
(loop (wait-for-input) c-x-pressed? #f))))))) (loop (wait-for-input) c-x-pressed? #f)))))))
(define (window-init-curses-win! window)
(set-app-window-curses-win!
window
(newwin (app-window-height window) (app-window-width window)
(app-window-y window) (app-window-x window))))
(define (make-inlying-app-window outer-window)
(make-app-window (+ (app-window-x outer-window) 1)
(+ (app-window-y outer-window) 1)
(- (app-window-width outer-window) 2)
(- (app-window-height outer-window) 2)
#f))
(define (init-windows!)
(init-screen)
(set! bar-1
(make-app-window 1 1
(- (COLS) 2) 2
#f))
(set! active-command-window
(make-app-window 1 (+ (round (/ (LINES) 3)) 2)
(- (COLS) 2) 3
#f))
(set! command-frame-window
(make-app-window 1 2
(- (COLS) 2) (- (app-window-y active-command-window) 2)
#f))
(set! command-window
(make-inlying-app-window command-frame-window))
(set! result-frame-window
(make-app-window 1 (+ (app-window-y active-command-window) 3)
(- (COLS) 2)
(- (- (LINES) 6) (app-window-height command-frame-window))
#f))
(set! result-window
(make-inlying-app-window result-frame-window))
(let ((all-windows (list bar-1 active-command-window
command-frame-window command-window
result-frame-window result-window)))
(for-each window-init-curses-win! all-windows)
(set-result-buffer-num-lines!
result-buffer (- (app-window-height result-window) 2))
(set-result-buffer-num-cols!
result-buffer (- (app-window-width result-window) 3))
(debug-message "init-windows!: bar-1 " bar-1
" active-command-window " active-command-window
" command-frame-window " command-frame-window
" command-window " command-window
" result-frame-window " result-frame-window
" result-window " result-window)
(for-each wclear
(map app-window-curses-win all-windows))
(clear)))
(define (get-path-list) (define (get-path-list)
(cond (cond
((getenv "PATH") ((getenv "PATH")
@ -548,8 +428,8 @@
(make-completion-set-for-executables (get-path-list))))))) (make-completion-set-for-executables (get-path-list)))))))
(define (paint-bar-1) (define (paint-bar-1)
(mvwaddstr (app-window-curses-win bar-1) 0 1 "SCSH-NUIT") (mvwaddstr (app-window-curses-win (bar-1)) 0 1 "SCSH-NUIT")
(wrefresh (app-window-curses-win bar-1))) (wrefresh (app-window-curses-win (bar-1))))
(define (paint-command-buffer-mode-indicator) (define (paint-command-buffer-mode-indicator)
(let ((mode-string (let ((mode-string
@ -560,19 +440,19 @@
"Scheme") "Scheme")
" ]"))) " ]")))
(mvwaddstr (mvwaddstr
(app-window-curses-win command-frame-window) (app-window-curses-win (command-frame-window))
0 0
(- (- (app-window-width command-frame-window) (- (- (app-window-width (command-frame-window))
(string-length mode-string)) (string-length mode-string))
2) 2)
mode-string))) mode-string)))
(define (paint-command-frame-window) (define (paint-command-frame-window)
(box (app-window-curses-win command-frame-window) (box (app-window-curses-win (command-frame-window))
(ascii->char 0) (ascii->char 0)) (ascii->char 0) (ascii->char 0))
(paint-command-buffer-mode-indicator) (paint-command-buffer-mode-indicator)
(paint-job-status-list) (paint-job-status-list)
(wrefresh (app-window-curses-win command-frame-window))) (wrefresh (app-window-curses-win (command-frame-window))))
(define paint-job-status-list (define paint-job-status-list
(let ((latest-statistics (initial-job-statistics))) (let ((latest-statistics (initial-job-statistics)))
@ -594,46 +474,46 @@
(line (string-append "[ " stat " ]"))) (line (string-append "[ " stat " ]")))
(set! latest-statistics statistics) (set! latest-statistics statistics)
(mvwaddstr (mvwaddstr
(app-window-curses-win command-frame-window) (app-window-curses-win (command-frame-window))
(- (app-window-height command-frame-window) 1) (- (app-window-height (command-frame-window)) 1)
(- (- (app-window-width command-frame-window) (- (- (app-window-width (command-frame-window))
(string-length line)) (string-length line))
2) 2)
line)))))) line))))))
(define (paint-command-window-contents) (define (paint-command-window-contents)
(set-buffer-num-lines! command-buffer (set-buffer-num-lines! (command-buffer)
(- (app-window-height command-window) 2)) (- (app-window-height (command-window)) 2))
(set-buffer-num-cols! command-buffer (set-buffer-num-cols! (command-buffer)
(- (app-window-width command-window) 3)) (- (app-window-width (command-window)) 3))
(werase (app-window-curses-win command-window)) (werase (app-window-curses-win (command-window)))
(print-command-buffer (app-window-curses-win command-window) (print-command-buffer (app-window-curses-win (command-window))
command-buffer)) (command-buffer)))
(define (refresh-command-window) (define (refresh-command-window)
(wrefresh (app-window-curses-win command-window))) (wrefresh (app-window-curses-win (command-window))))
(define (paint-result-frame-window) (define (paint-result-frame-window)
(let ((win (app-window-curses-win result-frame-window))) (let ((win (app-window-curses-win (result-frame-window))))
(wclear win) (wclear win)
(box win (ascii->char 0) (ascii->char 0)) (box win (ascii->char 0) (ascii->char 0))
(wrefresh win))) (wrefresh win)))
(define (paint-result-window entry) (define (paint-result-window entry)
(let ((win (app-window-curses-win result-window))) (let ((win (app-window-curses-win (result-window))))
(wclear win) (wclear win)
(send (history-entry-viewer entry) (send (history-entry-viewer entry)
'paint win result-buffer (focus-on-result-buffer?)))) 'paint win (result-buffer) (focus-on-result-buffer?))))
(define (refresh-result-window) (define (refresh-result-window)
(wrefresh (app-window-curses-win result-window))) (wrefresh (app-window-curses-win (result-window))))
(define (paint-result/command-buffer history-entry) (define (paint-result/command-buffer history-entry)
(paint-result-window history-entry) (paint-result-window history-entry)
(paint-active-command-window) (paint-active-command-window)
(scroll-command-buffer) (scroll-command-buffer)
(paint-command-window-contents) (paint-command-window-contents)
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-result-window) (refresh-result-window)
(refresh-command-window)) (refresh-command-window))
@ -644,15 +524,15 @@
(paint-active-command-window) (paint-active-command-window)
(paint-result-frame-window) (paint-result-frame-window)
;(paint-result-window) ;(paint-result-window)
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-command-window) (refresh-command-window)
(refresh-result-window)) (refresh-result-window))
(define (wait-for-input) (define (wait-for-input)
(noecho) (noecho)
(keypad (app-window-curses-win bar-1) #t) (keypad (app-window-curses-win (bar-1)) #t)
(set! active-keyboard-interrupt #f) (set! active-keyboard-interrupt #f)
(let ((ch (wgetch (app-window-curses-win bar-1)))) (let ((ch (wgetch (app-window-curses-win (bar-1)))))
(echo) (echo)
ch)) ch))
@ -661,15 +541,15 @@
((determine-plugin-by-type result) ((determine-plugin-by-type result)
=> (lambda (view-plugin) => (lambda (view-plugin)
((view-plugin-constructor view-plugin) ((view-plugin-constructor view-plugin)
result result-buffer))) result (result-buffer))))
(else (else
(make-standard-viewer result result-buffer)))) (make-standard-viewer result (result-buffer)))))
;;scroll buffer after one command was entered ;;scroll buffer after one command was entered
(define (scroll-command-buffer) (define (scroll-command-buffer)
(set-buffer-pos-line! command-buffer (set-buffer-pos-line! (command-buffer)
(+ (buffer-pos-line command-buffer) 1)) (+ (buffer-pos-line (command-buffer)) 1))
(set-buffer-pos-col! command-buffer 2)) (set-buffer-pos-col! (command-buffer) 2))
(define (init-evaluation-environment package) (define (init-evaluation-environment package)
(let ((structure (reify-structure package))) (let ((structure (reify-structure package)))
@ -685,9 +565,9 @@
(lambda (exp) (lambda (exp)
(with-fatal-and-capturing-error-handler (with-fatal-and-capturing-error-handler
(lambda (condition raw-continuation continuation decline) (lambda (condition raw-continuation continuation decline)
raw-continuation) raw-continuation)
(lambda () (lambda ()
(eval (read-sexp-from-string exp) env)))))) (eval (read-sexp-from-string exp) env))))))
(define (determine-plugin-by-type result) (define (determine-plugin-by-type result)
(find (lambda (r) (find (lambda (r)
@ -697,22 +577,22 @@
;;Management of the upper buffer ;;Management of the upper buffer
;;add a char to the buffer ;;add a char to the buffer
(define (add-to-command-buffer ch) (define (add-to-command-buffer ch)
(let* ((text (buffer-text command-buffer)) (let* ((text (buffer-text (command-buffer)))
(last-pos (- (length text) 1)) (last-pos (- (length text) 1))
(old-last-el (list-ref text last-pos)) (old-last-el (list-ref text last-pos))
(old-rest (sublist text 0 last-pos)) (old-rest (sublist text 0 last-pos))
(before-ch (substring old-last-el 0 (before-ch (substring old-last-el 0
(max 0 (- (buffer-pos-col command-buffer) 2)))) (max 0 (- (buffer-pos-col command-buffer) 2))))
(after-ch (substring old-last-el (after-ch (substring old-last-el
(max 0 (- (buffer-pos-col command-buffer) 2)) (max 0 (- (buffer-pos-col (command-buffer)) 2))
(string-length old-last-el))) (string-length old-last-el)))
(new-last-el (string-append before-ch (new-last-el (string-append before-ch
(string (ascii->char ch)) (string (ascii->char ch))
after-ch))) after-ch)))
(set-buffer-text! command-buffer (set-buffer-text! (command-buffer)
(append old-rest (list new-last-el))) (append old-rest (list new-last-el)))
(set-buffer-pos-col! command-buffer (set-buffer-pos-col! (command-buffer)
(+ (buffer-pos-col command-buffer) 1)))) (+ (buffer-pos-col (command-buffer)) 1))))
;;add a string to the buffer ;;add a string to the buffer
(define (add-string-to-command-buffer string) (define (add-string-to-command-buffer string)
@ -731,8 +611,8 @@
string)) string))
(define (paint-active-command-window) (define (paint-active-command-window)
(let ((win (app-window-curses-win active-command-window)) (let ((win (app-window-curses-win (active-command-window)))
(width (app-window-width active-command-window))) (width (app-window-width (active-command-window))))
(wclear win) (wclear win)
(box win (ascii->char 0) (ascii->char 0)) (box win (ascii->char 0) (ascii->char 0))
(cond (cond
@ -749,14 +629,14 @@
(cond (cond
((focus-on-command-buffer?) ((focus-on-command-buffer?)
(cursor-right-pos (cursor-right-pos
(app-window-curses-win command-window) (app-window-curses-win (command-window))
command-buffer)) command-buffer))
(else (else
(compute-y-x result-buffer) (compute-y-x result-buffer)
(wmove (app-window-curses-win result-window) (wmove (app-window-curses-win (result-window))
(result-buffer-y result-buffer) (result-buffer-y result-buffer)
(result-buffer-x result-buffer)) (result-buffer-x result-buffer))
(wrefresh (app-window-curses-win result-window))))) (wrefresh (app-window-curses-win (result-window))))))
;;compue pos-x and pos-y ;;compue pos-x and pos-y
(define (compute-y-x result-buffer) (define (compute-y-x result-buffer)
@ -875,26 +755,26 @@
(define (display-completed-line line cursor-pos) (define (display-completed-line line cursor-pos)
(debug-message "display-completed-line " line "," cursor-pos) (debug-message "display-completed-line " line "," cursor-pos)
(set-buffer-pos-col! command-buffer cursor-pos) (set-buffer-pos-col! (command-buffer) cursor-pos)
(set-buffer-text! command-buffer (set-buffer-text! (command-buffer)
(append (append
(drop-right (buffer-text command-buffer) 1) (drop-right (buffer-text (command-buffer)) 1)
(list line))) (list line)))
(wclrtoeol (app-window-curses-win command-window)) (wclrtoeol (app-window-curses-win (command-window)))
(print-command-buffer (app-window-curses-win command-window) (print-command-buffer (app-window-curses-win (command-window))
command-buffer) (command-buffer))
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-command-window)) (refresh-command-window))
(define (paint-completion-select-list select-list command) (define (paint-completion-select-list select-list command)
(let ((win (app-window-curses-win result-window))) (let ((win (app-window-curses-win (result-window))))
(wclear win) (wclear win)
(wattron win (A-BOLD)) (wattron win (A-BOLD))
(mvwaddstr win 0 0 (mvwaddstr win 0 0
(string-append "Possible completions for " command)) (string-append "Possible completions for " command))
(wattrset win (A-NORMAL)) (wattrset win (A-NORMAL))
(paint-selection-list-at select-list 0 2 (paint-selection-list-at select-list 0 2
win result-buffer (focus-on-result-buffer?)) win (result-buffer) (focus-on-result-buffer?))
(refresh-result-window))) (refresh-result-window)))
;; #### implement me ;; #### implement me
@ -923,7 +803,7 @@
(if (not prefix) (if (not prefix)
(error "could not determine token with cursor position" (error "could not determine token with cursor position"
tokens/cursor-list command tokens/cursor-list command
(- (buffer-pos-col command-buffer) 2))) (- (buffer-pos-col (command-buffer)) 2)))
(let ((completions (let ((completions
(call-completer command args (call-completer command args
prefix arg-pos))) prefix arg-pos)))
@ -938,13 +818,13 @@
(let* ((select-list (let* ((select-list
(completions->select-list (completions->select-list
completions completions
(- (result-buffer-num-lines result-buffer) 3))) (- (result-buffer-num-lines (result-buffer)) 3)))
(selector (selector
(make-completion-selector (make-completion-selector
select-list completions select-list completions
command args arg-pos))) command args arg-pos)))
(paint-completion-select-list select-list command) (paint-completion-select-list select-list command)
(move-cursor command-buffer result-buffer) (move-cursor (command-buffer) (result-buffer))
(refresh-command-window) (refresh-command-window)
selector))))))) selector)))))))
@ -966,7 +846,7 @@
(let ((new-select-list (let ((new-select-list
(select-list-handle-key-press select-list key))) (select-list-handle-key-press select-list key)))
(paint-completion-select-list (paint-completion-select-list
new-select-list (last (buffer-text command-buffer))) new-select-list (last (buffer-text (command-buffer))))
(make-completion-selector (make-completion-selector
new-select-list completions command arg arg-pos))) new-select-list completions command arg arg-pos)))
(else (else
@ -997,7 +877,7 @@
(else (values chars i))))) (else (values chars i)))))
(define (tokenize-command command) (define (tokenize-command command)
(let ((cursor-pos (- (buffer-pos-col command-buffer) 2))) ;; don't ask (let ((cursor-pos (- (buffer-pos-col (command-buffer)) 2))) ;; don't ask
(let lp ((chars (string->list command)) (let lp ((chars (string->list command))
(token "") (token "")
(tokens '()) (tokens '())

114
scheme/nuit-packages.scm
View File

@ -71,6 +71,52 @@
ncurses) ncurses)
(files layout)) (files layout))
;;; windows and buffers
(define-interface app-windows-interface
(export make-app-window
app-window?
app-window-x
app-window-y
app-window-height
app-window-width
app-window-curses-win))
(define-interface nuit-windows-interface
(export bar-1
active-command-window
command-frame-window
command-window
result-window
result-frame-window
command-buffer
result-buffer
focus-on-command-buffer?
focus-command-buffer!
focus-on-result-buffer?
focus-result-buffer!
init-windows!))
(define-interface result-buffer-changes-interface
(export result-buffer-other-object-has-focus-rv
signal-result-buffer-object-change))
(define-structures
((app-windows app-windows-interface)
(nuit-windows nuit-windows-interface)
(result-buffer-changes result-buffer-changes-interface))
(open scheme
define-record-types
threads
rendezvous
rendezvous-channels
ncurses
tty-debug
layout)
(files win))
;;; process viewer plugin ;;; process viewer plugin
(define-structure process-viewer (define-structure process-viewer
@ -129,6 +175,25 @@
tty-debug) tty-debug)
(files browse-directory-list)) (files browse-directory-list))
;;; terminal buffer
(define-interface terminal-buffer-interface
(export make-terminal-buffer
terminal-buffer?
terminal-buffer-add-char
curses-paint-terminal-buffer
curses-paint-terminal-buffer/complete))
(define-structure terminal-buffer terminal-buffer-interface
(open scheme-with-scsh
srfi-1
define-record-types
signals
ncurses
tty-debug)
(files termbuf))
;;; standard command plugin ;;; standard command plugin
(define-structure standard-command-plugin (define-structure standard-command-plugin
@ -226,6 +291,7 @@
signals signals
objects objects
console
jobs jobs
ncurses ncurses
focus-table focus-table
@ -275,6 +341,7 @@
let-opt let-opt
srfi-1 srfi-1
terminal-buffer
jobs jobs
focus-table focus-table
fs-object fs-object
@ -354,6 +421,30 @@
thread-fluids) thread-fluids)
(files complete)) (files complete))
;;; console
(define-interface console-interface
(export
make-console
console?
view-console
pause-console-output
resume-console-output))
(define-structure console console-interface
(open (modify scheme-with-scsh
(hide receive select))
define-record-types
threads
rendezvous
rendezvous-channels
plugin
tty-debug
result-buffer-changes
terminal-buffer)
(files console))
;;; jobs and joblist ;;; jobs and joblist
(define-interface job-interface (define-interface job-interface
@ -370,11 +461,19 @@
job-end-time job-end-time
job-proc job-proc
job-name job-name
job-run-status
job-console
running-jobs
ready-jobs
clear-ready-jobs!
jobs-with-new-output
jobs-waiting-for-input
signal-job signal-job
stop-job stop-job
continue-job continue-job
(run-as-background-job :syntax))) (run/bg :syntax)))
(define-interface joblist-interface (define-interface joblist-interface
(export running-jobs (export running-jobs
@ -395,7 +494,14 @@
rendezvous rendezvous
rendezvous-channels rendezvous-channels
rendezvous-placeholders) rendezvous-placeholders
terminal-buffer
nuit-windows
app-windows
layout
console)
(files job)) (files job))
;;; nuit ;;; nuit
@ -429,7 +535,11 @@
(receive cml-receive))) (receive cml-receive)))
let-opt let-opt
app-windows
nuit-windows
focus-table focus-table
result-buffer-changes
nuit-eval/focus-table nuit-eval/focus-table
fs-object fs-object
objects objects

20
scheme/std-command.scm
View File

@ -146,10 +146,18 @@
(register-plugin! (register-plugin!
(make-command-plugin "jobs" (make-command-plugin "jobs"
no-completer (lambda (command prefix args arg-pos)
'("running" "ready" "output" "waiting-for-input"))
(lambda (command args) (lambda (command args)
(append (append-map
(running-jobs) (ready-jobs) (lambda (arg)
(jobs-with-new-output) ;; #### warn if argument is unknown
(jobs-waiting-for-input))))) (cond
((assoc arg
`(("running" . ,running-jobs)
("ready" . ,ready-jobs)
("output" . ,jobs-with-new-output)
("input" . ,jobs-waiting-for-input)))
=> (lambda (p)
((cdr p))))))
(delete-duplicates args)))))

223
scheme/termbuf.scm Normal file
View File

@ -0,0 +1,223 @@
(define-record-type terminal-buffer :terminal-buffer
(really-make-terminal-buffer width height view-index
x y buffer repaint?
esc-code)
terminal-buffer?
(width terminal-buffer-width)
(height terminal-buffer-height)
(view-index terminal-buffer-view-index
set-terminal-buffer-view-index!)
(x terminal-buffer-x set-terminal-buffer-x!)
(y terminal-buffer-y set-terminal-buffer-y!)
(buffer terminal-buffer-buffer set-terminal-buffer-buffer!)
(repaint? terminal-buffer-repaint? set-terminal-buffer-repaint?!)
(esc-code terminal-buffer-esc-code set-terminal-buffer-esc-code!))
(define-record-discloser :terminal-buffer
(lambda (tb)
`(terminal-buffer
(width ,(terminal-buffer-width tb))
(height ,(terminal-buffer-height tb))
(x ,(terminal-buffer-x tb))
(y ,(terminal-buffer-y tb))
(repaint? ,(terminal-buffer-repaint? tb))
(esc-code ,(map char->ascii (string->list (terminal-buffer-esc-code tb)))))))
(define (make-terminal-buffer width height)
(let ((buffer (map
(lambda (ignore)
(make-empty-line width))
(iota height))))
(really-make-terminal-buffer width height buffer
0 0 buffer #f "")))
(define (line-at-cursor-position termbuf)
(list-ref (terminal-buffer-view-index termbuf)
(terminal-buffer-y termbuf)))
(define (make-empty-line width)
(make-string width #\space))
(define (cursor-at-end-of-line? termbuf)
(= (terminal-buffer-x termbuf)
(- (terminal-buffer-width termbuf) 1)))
(define (cursor-on-last-line? termbuf)
(= (terminal-buffer-y termbuf)
(- (terminal-buffer-height termbuf) 1)))
(define (append-empty-line termbuf)
(debug-message "append-empty-line")
(append! (terminal-buffer-buffer termbuf)
(list (make-empty-line (terminal-buffer-width termbuf)))))
(define (goto-next-line termbuf)
(debug-message "goto-next-line")
(set-terminal-buffer-y!
termbuf (+ (terminal-buffer-y termbuf) 1))
(maybe-scroll-terminal-buffer termbuf))
(define (move-cursor termbuf x-offset y-offset)
(debug-message "move-cursor " termbuf " " x-offset " " y-offset)
(let ((new-x (+ (terminal-buffer-x termbuf) x-offset))
(new-y (+ (terminal-buffer-y termbuf) y-offset)))
(cond
((< new-x 0)
(set-terminal-buffer-x! termbuf 0))
((>= new-x (terminal-buffer-width termbuf))
(set-terminal-buffer-x!
termbuf (- (terminal-buffer-width termbuf) 1)))
(else
(set-terminal-buffer-x! termbuf new-x)))
(cond
((< new-y 0)
(set-terminal-buffer-y! termbuf 0))
((>= new-y (terminal-buffer-width termbuf))
(set-terminal-buffer-y!
(termbuf (- (terminal-buffer-width termbuf) 1))))
(else
(set-terminal-buffer-y! termbuf new-y)))))
(define (scroll-view-index-down termbuf)
(set-terminal-buffer-view-index!
termbuf (cdr (terminal-buffer-view-index termbuf)))
(set-terminal-buffer-repaint?! termbuf #t))
(define (maybe-scroll-terminal-buffer termbuf)
(debug-message "maybe-scroll-terminal-buffer")
(and (>= (terminal-buffer-y termbuf)
(terminal-buffer-height termbuf))
(begin
(scroll-view-index-down termbuf)
(set-terminal-buffer-y!
termbuf
(- (terminal-buffer-y termbuf) 1)))))
(define (goto-beginning-of-line termbuf)
(debug-message "goto-beginning-of-line")
(set-terminal-buffer-x! termbuf 0))
(define (terminal-buffer-add-char termbuf char)
(debug-message "add-char " termbuf)
(cond
((not (string=? "" (terminal-buffer-esc-code termbuf)))
(read-escape-code termbuf char))
((char=? char (ascii->char 27))
(set-terminal-buffer-esc-code! termbuf (string char)))
((char=? char #\newline)
(if (cursor-on-last-line? termbuf)
(append-empty-line termbuf))
(goto-next-line termbuf)
(goto-beginning-of-line termbuf))
(else
(add-normal-char termbuf char))))
(define (add-normal-char termbuf char)
(cond
((cursor-at-end-of-line? termbuf)
(append-empty-line termbuf)
(goto-next-line termbuf)
(goto-beginning-of-line termbuf)
(insert-char termbuf char))
(else
(insert-char termbuf char)
(goto-next-char termbuf))))
(define (curses-paint-terminal-buffer termbuf win)
(if (terminal-buffer-repaint? termbuf)
(clear/repaint-buffer termbuf win)
(paint-single-line termbuf win)))
(define (clear/repaint-buffer termbuf win)
(debug-message "clear/repaint-buffer")
(wclear win)
(let lp ((i (terminal-buffer-height termbuf))
(lines (terminal-buffer-view-index termbuf))
(y 0))
(if (zero? i)
'blorf
(begin
(mvwaddstr win y 0 (car lines))
(lp (- i 1) (cdr lines) (+ y 1)))))
(position-cursor termbuf win))
(define curses-paint-terminal-buffer/complete
clear/repaint-buffer)
(define (paint-single-line termbuf win)
(debug-message "paint-single-line " termbuf)
(wclrtoeol win)
(mvwaddstr win
(terminal-buffer-y termbuf) 0
(line-at-cursor-position termbuf))
(position-cursor termbuf win))
(define (position-cursor termbuf win)
(wmove win
(terminal-buffer-y termbuf)
(terminal-buffer-x termbuf)))
(define (insert-char termbuf char)
(string-set! (line-at-cursor-position termbuf)
(terminal-buffer-x termbuf)
char))
(define (goto-next-char termbuf)
(set-terminal-buffer-x!
termbuf (+ 1 (terminal-buffer-x termbuf))))
(define (read-escape-code termbuf char)
(debug-message "read-escape-code " (char->ascii char) " " termbuf)
(let ((code (string-append
(terminal-buffer-esc-code termbuf)
(string char))))
(cond
;; very ugly hack
((> (string-length code) 5)
(set-terminal-buffer-esc-code! termbuf ""))
((recognize-simple-cursor-movement code)
=> (lambda (lst)
(apply move-cursor (cons termbuf lst))
(set-terminal-buffer-esc-code! termbuf "")))
((recognize-cursor-movement code)
=> (lambda (lst)
(apply move-cursor (cons termbuf lst))
(set-terminal-buffer-esc-code! termbuf "")))
(else
(set-terminal-buffer-esc-code! termbuf code)))))
(define (recognize-cursor-movement partial-code)
(debug-message "recognize-cursor-movement " partial-code)
(if-match
(regexp-search (rx (: ,(ascii->char 27)
#\[ (submatch digit) (submatch ("ABCD"))
eos))
partial-code)
(whole-code count direction)
(cond
((string=? direction "A")
(list 0 (- (string->number count))))
((string=? direction "B")
(list 0 (string->number count)))
((string=? direction "C")
(list (string->number count) 0))
((string=? direction "D")
(list (- (string->number count)) 0))
(else (error 'gnarf direction)))
#f))
(define (recognize-simple-cursor-movement partial-code)
(debug-message "recognize-simple-cursor-movement ")
(if-match
(regexp-search (rx (: ,(ascii->char 27) (? #\[) (? #\O) (submatch ("ABCD")) eos))
partial-code)
(whole-code direction)
(cond
((string=? direction "A") '( 0 -1))
((string=? direction "B") '( 0 1))
((string=? direction "C") '( 1 0))
((string=? direction "D") '(-1 0))
(else (error 'gnarf2 (string? direction) (char? direction) )))
(begin (debug-message "does not match ") #f)))

147
scheme/win.scm Normal file
View File

@ -0,0 +1,147 @@
(define-record-type app-window :app-window
(make-app-window x y width height curses-win)
app-window?
(x app-window-x)
(y app-window-y)
(width app-window-width)
(height app-window-height)
(curses-win app-window-curses-win set-app-window-curses-win!))
(define-record-discloser :app-window
(lambda (rec)
`(app-window
(x ,(app-window-x rec)) (y ,(app-window-y rec))
(w ,(app-window-width rec)) (h ,(app-window-height rec)))))
(define *bar-1* #f)
(define (bar-1) *bar-1*)
(define *active-command-window* #f)
(define (active-command-window) *active-command-window*)
(define *command-frame-window* #f)
(define (command-frame-window) *command-frame-window*)
(define *command-window* #f)
(define (command-window) *command-window*)
(define *result-window* #f)
(define (result-window) *result-window*)
(define *result-frame-window* #f)
(define (result-frame-window) *result-frame-window*)
(define *command-buffer*
(make-buffer '("Welcome to the scsh-ncurses-ui!" "")
2 2 2 1 1
0 0
#t 1))
(define (command-buffer) *command-buffer*)
(define *result-buffer*
(make-result-buffer 0 0 0 0
#f #f ; set in INIT-WINDOWS
'() '()))
(define (result-buffer) *result-buffer*)
(define *focus-buffer* 'command-buffer)
(define (focus-on-command-buffer?)
(eq? *focus-buffer* 'command-buffer))
(define (focus-command-buffer!)
(set! *focus-buffer* 'command-buffer))
(define (focus-on-result-buffer?)
(eq? *focus-buffer* 'result-buffer))
(define (focus-result-buffer!)
(set! *focus-buffer* 'result-buffer))
(define (make-inlying-app-window outer-window)
(make-app-window (+ (app-window-x outer-window) 1)
(+ (app-window-y outer-window) 1)
(- (app-window-width outer-window) 2)
(- (app-window-height outer-window) 2)
#f))
(define (window-init-curses-win! window)
(set-app-window-curses-win!
window
(newwin (app-window-height window) (app-window-width window)
(app-window-y window) (app-window-x window))))
(define (init-windows!)
(set! *bar-1*
(make-app-window 1 1
(- (COLS) 2) 2
#f))
(set! *active-command-window*
(make-app-window 1 (+ (round (/ (LINES) 3)) 2)
(- (COLS) 2) 3
#f))
(set! *command-frame-window*
(make-app-window 1 2
(- (COLS) 2) (- (app-window-y (active-command-window)) 2)
#f))
(set! *command-window*
(make-inlying-app-window (command-frame-window)))
(set! *result-frame-window*
(make-app-window 1 (+ (app-window-y (active-command-window)) 3)
(- (COLS) 2)
(- (- (LINES) 6) (app-window-height (command-frame-window)))
#f))
(set! *result-window*
(make-inlying-app-window (result-frame-window)))
(let ((all-windows
(list (bar-1) (active-command-window)
(command-frame-window) (command-window)
(result-frame-window) (result-window))))
(for-each window-init-curses-win! all-windows)
(set-result-buffer-num-lines!
*result-buffer* (- (app-window-height (result-window)) 2))
(set-result-buffer-num-cols!
*result-buffer* (- (app-window-width (result-window)) 3))
(for-each wclear
(map app-window-curses-win all-windows))))
;; result-buffer-object-change-channel
(define result-buffer-changed-channel
(make-channel))
(define result-buffer-changes-subscribers
(make-channel))
(define (signal-result-buffer-object-change)
(debug-message "signal-result-buffer-object-change")
(send result-buffer-changed-channel 'ignore))
(define (spawn-result-buffer-surveillant)
(spawn
(lambda ()
(let lp ()
(select
(wrap (receive-rv result-buffer-changes-subscribers)
(lambda (answer-channel)
(debug-message "result-buffer-surveillant "
answer-channel)
(receive result-buffer-changed-channel)
(send answer-channel 'ignore)
(lp)))
(wrap (receive-rv result-buffer-changed-channel)
(lambda (ignore)
(debug-message "result-buffer-surveillant")
(lp))))))))
(define (result-buffer-other-object-has-focus-rv)
(let ((answer-channel (make-channel)))
(send result-buffer-changes-subscribers answer-channel)
(receive-rv answer-channel)))
(spawn-result-buffer-surveillant)