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!
(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
(really-make-job name pty-in pty-out proc
status
start-time end-time
run-status)
(really-make-job name console
proc status
start-time end-time run-status)
job?
(name job-name)
(pty-in job-pty-in)
(pty-out job-pty-out)
(console job-console)
(proc job-proc)
(status really-job-status)
(start-time job-start-time)
@ -17,9 +15,13 @@
(lambda (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
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)))
(spawn-job-status-surveillant job)
(add-job! job)
@ -62,6 +64,12 @@
(define (continue-job 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
(define add-job-channel
@ -70,6 +78,9 @@
(define get-job-list-channel
(make-channel))
(define clear-ready-jobs-channel
(make-channel))
(define (add-job! job)
(send add-job-channel job))
@ -83,6 +94,9 @@
(send get-job-list-channel (cons 'ready answer-channel))
(receive answer-channel)))
(define (clear-ready-jobs!)
(send clear-ready-jobs-channel 'ignored))
(define (jobs-with-new-output)
(let ((answer-channel (make-channel)))
(send get-job-list-channel (cons 'new-output answer-channel))
@ -119,6 +133,10 @@
(lambda (new-job)
(lp (cons new-job running)
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)
(lambda (state.channel)
@ -155,7 +173,7 @@
(lambda args
(display args))))
(define-syntax run-as-background-job
(define-syntax run/bg
(syntax-rules ()
((_ epf)
(call-with-values
@ -164,6 +182,10 @@
(lambda ()
(exec-epf epf))))
(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

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
(syntax-rules ()
((_ ?test ?do-this ...)
@ -16,83 +14,6 @@
(release-lock lock)
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
(define *command-buffer-mode* 'scheme)
@ -108,6 +29,15 @@
(define (enter-command-mode!)
(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
(define history-pos 0)
@ -214,7 +144,7 @@
(refresh-result-window))
(else
(focus-command-buffer!)
(move-cursor command-buffer result-buffer)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window))))
(define (toggle-command/scheme-mode)
@ -225,11 +155,11 @@
(enter-command-mode!)))
(paint-command-frame-window)
(paint-command-window-contents)
(move-cursor command-buffer result-buffer)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window))
(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)
(cond
((string=? command-line "")
@ -262,10 +192,11 @@
(make-history-entry command args viewer)))
;; FIXME, use insert here
(append-to-history! new-entry)
(signal-result-buffer-object-change)
(obtain-lock paint-lock)
(paint-result-window new-entry)
(refresh-result-window)
(move-cursor command-buffer result-buffer)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(release-lock paint-lock)))
@ -280,10 +211,11 @@
(make-history-entry command args viewer)))
;; #### shouldn't we use some kind of insertion here?
(append-to-history! new-entry)
(signal-result-buffer-object-change)
(obtain-lock paint-lock)
(paint-result-window new-entry)
(refresh-result-window)
(move-cursor command-buffer result-buffer)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(release-lock paint-lock))))
@ -295,9 +227,9 @@
(send (current-viewer)
'get-selection
(command-buffer-in-scheme-mode?) (focus-table)))
(print-command-buffer (app-window-curses-win command-window)
command-buffer)
(move-cursor command-buffer result-buffer)
(print-command-buffer (app-window-curses-win (command-window))
(command-buffer))
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window))
(define (paste-focus-object/refresh viewer)
@ -308,15 +240,18 @@
(command-buffer-in-scheme-mode?)
(focus-table))
(send (current-viewer) 'get-focus-object (focus-table))))
(print-command-buffer (app-window-curses-win command-window)
command-buffer)
(move-cursor command-buffer result-buffer)
(print-command-buffer (app-window-curses-win (command-window))
(command-buffer))
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window))
;; handle input
(define (run)
(init-screen)
(init-windows!)
(clear)
(init-executables-completion-set!)
;; init joblist
@ -329,8 +264,8 @@
(paint-command-frame-window)
(paint-job-status-list stats)
(paint-command-window-contents)
(wrefresh (app-window-curses-win command-frame-window))
(move-cursor command-buffer result-buffer)
(wrefresh (app-window-curses-win (command-frame-window)))
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(release-lock paint-lock)
(lp (cml-receive statistics-channel))))))
@ -368,7 +303,7 @@
((and (focus-on-command-buffer?)
(= ch key-tab))
(let ((maybe-selector
(offer-completions (last (buffer-text command-buffer)))))
(offer-completions (last (buffer-text (command-buffer))))))
(loop (wait-for-input) #f maybe-selector)))
;; F7 toggle scheme-mode / command-mode (FIXME: find a better key)
@ -422,6 +357,7 @@
(obtain-lock paint-lock)
(when (current-history-item)
(paint-active-command-window)
(signal-result-buffer-object-change)
(paint-result-window (entry-data (current-history-item))))
(refresh-result-window)
(release-lock paint-lock)
@ -433,18 +369,19 @@
(obtain-lock paint-lock)
(when (current-history-item)
(paint-active-command-window)
(signal-result-buffer-object-change)
(paint-result-window (entry-data (current-history-item))))
(refresh-result-window)
(release-lock paint-lock)
(loop (wait-for-input) c-x-pressed? #f))
((and (focus-on-command-buffer?) (= ch 10))
(input command-buffer ch)
(input (command-buffer) ch)
(obtain-lock paint-lock)
(werase (app-window-curses-win command-window))
(print-command-buffer (app-window-curses-win command-window)
command-buffer)
(move-cursor command-buffer result-buffer)
(werase (app-window-curses-win (command-window)))
(print-command-buffer (app-window-curses-win (command-window))
(command-buffer))
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(release-lock paint-lock)
(handle-return-key)
@ -459,78 +396,21 @@
'key-press ch c-x-pressed?))
(obtain-lock paint-lock)
(paint-result-window (entry-data (current-history-item)))
(move-cursor command-buffer result-buffer)
(move-cursor (command-buffer) (result-buffer))
(refresh-result-window)
(release-lock paint-lock))
(loop (wait-for-input) #f #f))
(else
(input command-buffer ch)
(input (command-buffer) ch)
(obtain-lock paint-lock)
(werase (app-window-curses-win command-window))
(print-command-buffer (app-window-curses-win command-window)
command-buffer)
(move-cursor command-buffer result-buffer)
(werase (app-window-curses-win (command-window)))
(print-command-buffer (app-window-curses-win (command-window))
(command-buffer))
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(release-lock paint-lock)
(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)
(cond
((getenv "PATH")
@ -548,8 +428,8 @@
(make-completion-set-for-executables (get-path-list)))))))
(define (paint-bar-1)
(mvwaddstr (app-window-curses-win bar-1) 0 1 "SCSH-NUIT")
(wrefresh (app-window-curses-win bar-1)))
(mvwaddstr (app-window-curses-win (bar-1)) 0 1 "SCSH-NUIT")
(wrefresh (app-window-curses-win (bar-1))))
(define (paint-command-buffer-mode-indicator)
(let ((mode-string
@ -560,19 +440,19 @@
"Scheme")
" ]")))
(mvwaddstr
(app-window-curses-win command-frame-window)
(app-window-curses-win (command-frame-window))
0
(- (- (app-window-width command-frame-window)
(- (- (app-window-width (command-frame-window))
(string-length mode-string))
2)
mode-string)))
(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))
(paint-command-buffer-mode-indicator)
(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
(let ((latest-statistics (initial-job-statistics)))
@ -594,46 +474,46 @@
(line (string-append "[ " stat " ]")))
(set! latest-statistics statistics)
(mvwaddstr
(app-window-curses-win command-frame-window)
(- (app-window-height command-frame-window) 1)
(- (- (app-window-width command-frame-window)
(app-window-curses-win (command-frame-window))
(- (app-window-height (command-frame-window)) 1)
(- (- (app-window-width (command-frame-window))
(string-length line))
2)
line))))))
(define (paint-command-window-contents)
(set-buffer-num-lines! command-buffer
(- (app-window-height command-window) 2))
(set-buffer-num-cols! command-buffer
(- (app-window-width command-window) 3))
(werase (app-window-curses-win command-window))
(print-command-buffer (app-window-curses-win command-window)
command-buffer))
(set-buffer-num-lines! (command-buffer)
(- (app-window-height (command-window)) 2))
(set-buffer-num-cols! (command-buffer)
(- (app-window-width (command-window)) 3))
(werase (app-window-curses-win (command-window)))
(print-command-buffer (app-window-curses-win (command-window))
(command-buffer)))
(define (refresh-command-window)
(wrefresh (app-window-curses-win command-window)))
(wrefresh (app-window-curses-win (command-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)
(box win (ascii->char 0) (ascii->char 0))
(wrefresh win)))
(define (paint-result-window entry)
(let ((win (app-window-curses-win result-window)))
(let ((win (app-window-curses-win (result-window))))
(wclear win)
(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)
(wrefresh (app-window-curses-win result-window)))
(wrefresh (app-window-curses-win (result-window))))
(define (paint-result/command-buffer history-entry)
(paint-result-window history-entry)
(paint-active-command-window)
(scroll-command-buffer)
(paint-command-window-contents)
(move-cursor command-buffer result-buffer)
(move-cursor (command-buffer) (result-buffer))
(refresh-result-window)
(refresh-command-window))
@ -644,15 +524,15 @@
(paint-active-command-window)
(paint-result-frame-window)
;(paint-result-window)
(move-cursor command-buffer result-buffer)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(refresh-result-window))
(define (wait-for-input)
(noecho)
(keypad (app-window-curses-win bar-1) #t)
(keypad (app-window-curses-win (bar-1)) #t)
(set! active-keyboard-interrupt #f)
(let ((ch (wgetch (app-window-curses-win bar-1))))
(let ((ch (wgetch (app-window-curses-win (bar-1)))))
(echo)
ch))
@ -661,15 +541,15 @@
((determine-plugin-by-type result)
=> (lambda (view-plugin)
((view-plugin-constructor view-plugin)
result result-buffer)))
result (result-buffer))))
(else
(make-standard-viewer result result-buffer))))
(make-standard-viewer result (result-buffer)))))
;;scroll buffer after one command was entered
(define (scroll-command-buffer)
(set-buffer-pos-line! command-buffer
(+ (buffer-pos-line command-buffer) 1))
(set-buffer-pos-col! command-buffer 2))
(set-buffer-pos-line! (command-buffer)
(+ (buffer-pos-line (command-buffer)) 1))
(set-buffer-pos-col! (command-buffer) 2))
(define (init-evaluation-environment package)
(let ((structure (reify-structure package)))
@ -685,9 +565,9 @@
(lambda (exp)
(with-fatal-and-capturing-error-handler
(lambda (condition raw-continuation continuation decline)
raw-continuation)
raw-continuation)
(lambda ()
(eval (read-sexp-from-string exp) env))))))
(eval (read-sexp-from-string exp) env))))))
(define (determine-plugin-by-type result)
(find (lambda (r)
@ -697,22 +577,22 @@
;;Management of the upper buffer
;;add a char to the buffer
(define (add-to-command-buffer ch)
(let* ((text (buffer-text command-buffer))
(let* ((text (buffer-text (command-buffer)))
(last-pos (- (length text) 1))
(old-last-el (list-ref text last-pos))
(old-rest (sublist text 0 last-pos))
(before-ch (substring old-last-el 0
(max 0 (- (buffer-pos-col command-buffer) 2))))
(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)))
(new-last-el (string-append before-ch
(string (ascii->char ch))
after-ch)))
(set-buffer-text! command-buffer
(set-buffer-text! (command-buffer)
(append old-rest (list new-last-el)))
(set-buffer-pos-col! command-buffer
(+ (buffer-pos-col command-buffer) 1))))
(set-buffer-pos-col! (command-buffer)
(+ (buffer-pos-col (command-buffer)) 1))))
;;add a string to the buffer
(define (add-string-to-command-buffer string)
@ -731,8 +611,8 @@
string))
(define (paint-active-command-window)
(let ((win (app-window-curses-win active-command-window))
(width (app-window-width active-command-window)))
(let ((win (app-window-curses-win (active-command-window)))
(width (app-window-width (active-command-window))))
(wclear win)
(box win (ascii->char 0) (ascii->char 0))
(cond
@ -749,14 +629,14 @@
(cond
((focus-on-command-buffer?)
(cursor-right-pos
(app-window-curses-win command-window)
(app-window-curses-win (command-window))
command-buffer))
(else
(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-x result-buffer))
(wrefresh (app-window-curses-win result-window)))))
(wrefresh (app-window-curses-win (result-window))))))
;;compue pos-x and pos-y
(define (compute-y-x result-buffer)
@ -875,26 +755,26 @@
(define (display-completed-line line cursor-pos)
(debug-message "display-completed-line " line "," cursor-pos)
(set-buffer-pos-col! command-buffer cursor-pos)
(set-buffer-text! command-buffer
(set-buffer-pos-col! (command-buffer) cursor-pos)
(set-buffer-text! (command-buffer)
(append
(drop-right (buffer-text command-buffer) 1)
(drop-right (buffer-text (command-buffer)) 1)
(list line)))
(wclrtoeol (app-window-curses-win command-window))
(print-command-buffer (app-window-curses-win command-window)
command-buffer)
(move-cursor command-buffer result-buffer)
(wclrtoeol (app-window-curses-win (command-window)))
(print-command-buffer (app-window-curses-win (command-window))
(command-buffer))
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window))
(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)
(wattron win (A-BOLD))
(mvwaddstr win 0 0
(string-append "Possible completions for " command))
(wattrset win (A-NORMAL))
(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)))
;; #### implement me
@ -923,7 +803,7 @@
(if (not prefix)
(error "could not determine token with cursor position"
tokens/cursor-list command
(- (buffer-pos-col command-buffer) 2)))
(- (buffer-pos-col (command-buffer)) 2)))
(let ((completions
(call-completer command args
prefix arg-pos)))
@ -938,13 +818,13 @@
(let* ((select-list
(completions->select-list
completions
(- (result-buffer-num-lines result-buffer) 3)))
(- (result-buffer-num-lines (result-buffer)) 3)))
(selector
(make-completion-selector
select-list completions
command args arg-pos)))
(paint-completion-select-list select-list command)
(move-cursor command-buffer result-buffer)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
selector)))))))
@ -966,7 +846,7 @@
(let ((new-select-list
(select-list-handle-key-press select-list key)))
(paint-completion-select-list
new-select-list (last (buffer-text command-buffer)))
new-select-list (last (buffer-text (command-buffer))))
(make-completion-selector
new-select-list completions command arg arg-pos)))
(else
@ -997,7 +877,7 @@
(else (values chars i)))))
(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))
(token "")
(tokens '())

114
scheme/nuit-packages.scm
View File

@ -71,6 +71,52 @@
ncurses)
(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
(define-structure process-viewer
@ -129,6 +175,25 @@
tty-debug)
(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
(define-structure standard-command-plugin
@ -226,6 +291,7 @@
signals
objects
console
jobs
ncurses
focus-table
@ -275,6 +341,7 @@
let-opt
srfi-1
terminal-buffer
jobs
focus-table
fs-object
@ -354,6 +421,30 @@
thread-fluids)
(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
(define-interface job-interface
@ -370,11 +461,19 @@
job-end-time
job-proc
job-name
job-run-status
job-console
running-jobs
ready-jobs
clear-ready-jobs!
jobs-with-new-output
jobs-waiting-for-input
signal-job
stop-job
continue-job
(run-as-background-job :syntax)))
(run/bg :syntax)))
(define-interface joblist-interface
(export running-jobs
@ -395,7 +494,14 @@
rendezvous
rendezvous-channels
rendezvous-placeholders)
rendezvous-placeholders
terminal-buffer
nuit-windows
app-windows
layout
console)
(files job))
;;; nuit
@ -429,7 +535,11 @@
(receive cml-receive)))
let-opt
app-windows
nuit-windows
focus-table
result-buffer-changes
nuit-eval/focus-table
fs-object
objects

20
scheme/std-command.scm
View File

@ -146,10 +146,18 @@
(register-plugin!
(make-command-plugin "jobs"
no-completer
(lambda (command prefix args arg-pos)
'("running" "ready" "output" "waiting-for-input"))
(lambda (command args)
(append
(running-jobs) (ready-jobs)
(jobs-with-new-output)
(jobs-waiting-for-input)))))
(append-map
(lambda (arg)
;; #### warn if argument is unknown
(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)