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

the command-window now uses command-buffers based on input-fields instead of input-buffers

This commit is contained in:
chetz 2006-03-28 09:44:39 +00:00
parent 1ef838007d
commit 475177b891
4 changed files with 468 additions and 101 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

404
scheme/command-buffer.scm Normal file
View File

@ -0,0 +1,404 @@
;; History
;(define command-history-pos 0)
(define the-command-history (make-empty-history))
(define (command-history) the-command-history)
(define *current-command-history-item* #f)
(define (current-command-history-item)
*current-command-history-item*)
(define-record-type command-history-entry :command-history-entry
(make-command-history-entry prompt window-lines)
command-history-entry?
(prompt command-history-entry-prompt)
(window-lines command-history-entry-window-lines))
(define input-field->command-history-item
(lambda (input-field)
(let* ((prompt (input-field-prompt input-field))
(w-l (map list->string
(input-field-window-lines input-field)))
(window-lines (cons (substring (car w-l)
(string-length prompt)
(string-length (car w-l)))
(cdr w-l))))
(make-command-history-entry prompt window-lines))))
(define (append-to-command-history! history-entry)
(append-history-item! the-command-history history-entry)
(set! *current-command-history-item*
(history-last-entry the-command-history)))
;; one step back in the history
(define (command-history-back!)
(cond
((and (current-command-history-item)
(history-prev-entry (current-command-history-item)))
=> (lambda (prev)
(set! *current-command-history-item* prev)))
(else (values))))
;; one step forward
(define (command-history-forward!)
(cond
((and *current-command-history-item*
(history-next-entry *current-command-history-item*))
=> (lambda (next)
(set! *current-command-history-item* next)))
(else (values))))
(define *history-down?* #t)
(define history-up
(lambda (com-buf)
(let ((last-entry (history-last-entry (command-history))))
(if last-entry
(if *history-down?*
(begin
(set! *history-down?* #f)
(set-command-buffer-keep-in-mind! com-buf
(input-field-text (command-buffer-input-field com-buf)))
(set-command-buffer-text! com-buf
(fold-right string-append
""
(command-history-entry-window-lines
(entry-data *current-command-history-item*)))))
(let ((current-window-lines (command-history-entry-window-lines
(entry-data *current-command-history-item*))))
(command-history-back!)
(set-command-buffer-text! com-buf
(fold-right string-append
""
(command-history-entry-window-lines
(entry-data *current-command-history-item*))))
(if (and (not (eq? *current-command-history-item*
(history-first-entry (command-history))))
(equal? current-window-lines
(command-history-entry-window-lines
(entry-data *current-command-history-item*))))
(history-up com-buf)
(values))))
(values)))))
(define history-down
(lambda (com-buf)
(let ((last-entry (history-last-entry (command-history))))
(if last-entry
(if (eq? *current-command-history-item*
(history-last-entry (command-history)))
(begin
(if (command-buffer-keep-in-mind com-buf)
(set-command-buffer-text! com-buf (command-buffer-keep-in-mind com-buf)))
(set! *history-down?* #t))
(let ((current-window-lines (command-history-entry-window-lines
(entry-data *current-command-history-item*))))
(command-history-forward!)
(set-command-buffer-text! com-buf
(fold-right string-append
""
(command-history-entry-window-lines
(entry-data *current-command-history-item*))))
(if (equal? current-window-lines
(command-history-entry-window-lines
(entry-data *current-command-history-item*)))
(history-down com-buf)
(values))))
(values)))))
;; Buffer
(define-record-type command-buffer :command-buffer
(really-make-command-buffer win
prompt
x-loc y-loc
x-dim y-dim
history-scroll
input-field
keep-in-mind)
command-buffer?
(win command-buffer-win set-command-buffer-win!)
(prompt command-buffer-prompt set-command-buffer-prompt!)
(x-loc command-buffer-x-loc set-command-buffer-x-loc!)
(y-loc command-buffer-y-loc set-command-buffer-y-loc!)
(x-dim command-buffer-x-dim set-command-buffer-x-dim!)
(y-dim command-buffer-y-dim set-command-buffer-y-dim!)
(history-scroll command-buffer-history-scroll set-command-buffer-history-scroll!)
(input-field command-buffer-input-field set-command-buffer-input-field!)
(keep-in-mind command-buffer-keep-in-mind set-command-buffer-keep-in-mind!))
(define make-command-buffer
(lambda (win prompt x-loc y-loc x-dim y-dim)
(really-make-command-buffer win
prompt
x-loc y-loc
x-dim y-dim
0
(make&install-input-field win
x-loc y-loc ;; later y-loc and y-dim will
x-dim y-dim ;; be dynamically calculated
(if (procedure? prompt)
(prompt)
prompt)
""
standard-behavior-pro)
#f)))
(define make-buffer make-command-buffer)
(define buffer-pos-col
(lambda (com-buf)
(let ((input-field (command-buffer-input-field com-buf)))
(- (input-field-x-edit-pos input-field)
(string-length (input-field-prompt input-field))))))
(define history-lines-from-history
(lambda (n)
(let loop ((current-entry (history-last-entry (command-history)))
(n n)
(history-lines '()))
(if (or (< n 0)
(not current-entry))
history-lines
(let* ((current-item (entry-data current-entry))
(new-lines-wo-prompt (command-history-entry-window-lines current-item))
(new-lines (cons (string-append (command-history-entry-prompt current-item)
(car new-lines-wo-prompt))
(cdr new-lines-wo-prompt)))
(new-n (- n (length new-lines))))
(loop (history-prev-entry current-entry)
new-n
(append new-lines history-lines)))))))
(define print-command-buffer
(lambda (com-buf)
(print-history-lines com-buf)
(print-input-field com-buf)))
(define print-history-lines
(lambda (com-buf)
(let* ((win (command-buffer-win com-buf))
(x-loc (command-buffer-x-loc com-buf))
(y-loc (command-buffer-y-loc com-buf))
(x-dim (command-buffer-x-dim com-buf))
(history-lines (history-lines-from-history (+ (command-buffer-y-dim com-buf)
(command-buffer-history-scroll com-buf))))
(history-lines-to (take history-lines
(max (- (length history-lines)
(command-buffer-history-scroll com-buf))
(- (command-buffer-y-dim com-buf)
(input-field-y-size
(command-buffer-input-field com-buf))))))
(history-lines-to-print (drop history-lines-to
(max 0
(- (length history-lines-to)
(- (command-buffer-y-dim com-buf)
(input-field-y-size
(command-buffer-input-field com-buf))))))))
(let loop ((lines history-lines-to-print)
(y-ofst 0))
(if (null? lines)
#t
(begin
(mvwaddstr win
(+ y-loc y-ofst)
x-loc
(fill-string (car lines) #\space x-dim))
(loop (cdr lines)
(+ y-ofst 1))))))))
(define print-input-field
(lambda (com-buf)
(input-field-refresh (command-buffer-input-field com-buf))))
;; Input
(define input
(lambda (com-buf asc)
(cond ((or (= asc 13)
(= asc 10))
(return-pressed-action com-buf))
((= asc key-up)
(history-up com-buf))
((= asc key-down)
(history-down com-buf))
; ((= asc 23) ; C-w
; (scroll-up-history-window-lines com-buf))
; ((= asc 5) ; C-e
; (scroll-down-history-window-lines com-buf))
(else
(call-with-values
(lambda ()
(send-input-field (command-buffer-input-field com-buf)
asc))
(lambda (was-known has-changed)
(if (eq? was-known 'buffer-full)
(enlarge-input-field com-buf asc)
#t)))))))
(define return-pressed-action
(lambda (com-buf)
(append-to-command-history! (input-field->command-history-item
(command-buffer-input-field com-buf)))
(set-command-buffer-keep-in-mind! com-buf #f)
(set-command-buffer-history-scroll! com-buf 0)
(set! *current-command-history-item* (history-last-entry (command-history)))
(set! *history-down?* #t)
(let ((new-input-field-y-dim (max 1
(- (command-buffer-y-dim com-buf)
(length (history-lines-from-history
(command-buffer-y-dim com-buf))))))
(old-input-field (command-buffer-input-field com-buf)))
(set-command-buffer-input-field! com-buf
(make&install-input-field
(command-buffer-win com-buf)
(command-buffer-x-loc com-buf)
(+ (command-buffer-y-loc com-buf)
(- (command-buffer-y-dim com-buf)
new-input-field-y-dim))
(command-buffer-x-dim com-buf)
new-input-field-y-dim
(let ((prompt (command-buffer-prompt com-buf)))
(if (procedure? prompt)
(prompt)
prompt))
""
standard-behavior-pro))
(remove-input-field old-input-field))
(print-command-buffer com-buf)))
(define scroll-up-history-window-lines
(lambda (com-buf)
(let ((scroll (command-buffer-history-scroll com-buf)))
(if (< scroll (- (length (history-lines-from-history (+ scroll
(command-buffer-y-dim com-buf))))
(- (command-buffer-y-dim com-buf)
(input-field-y-size (command-buffer-input-field com-buf)))))
(begin
(set-command-buffer-history-scroll! com-buf (+ scroll 1))
(print-command-buffer com-buf))))))
(define scroll-down-history-window-lines
(lambda (com-buf)
(let ((scroll (command-buffer-history-scroll com-buf)))
(if (> scroll 0)
(begin
(set-command-buffer-history-scroll! com-buf (- scroll 1))
(print-command-buffer com-buf))))))
(define command-buffer-text
(lambda (com-buf)
(input-field-text (command-buffer-input-field com-buf))))
(define buffer-text command-buffer-text)
(define set-command-buffer-text!
(lambda (com-buf text)
(let* ((buffer-y-dim (command-buffer-y-dim com-buf))
(buffer-x-dim (command-buffer-x-dim com-buf))
(input-field (command-buffer-input-field com-buf))
(prompt (input-field-prompt input-field))
(needed-y-dim (max 1
(+ (quotient (+ (string-length prompt)
(string-length text))
buffer-x-dim)
1))))
(set-input-field-text! input-field "")
(if (> needed-y-dim buffer-y-dim)
(begin
(input-field-move input-field
(command-buffer-x-loc com-buf)
(command-buffer-y-loc com-buf))
(input-field-resize input-field
buffer-x-dim
buffer-y-dim)
(if (not (input-field-y-scroll input-field))
(input-field-toggle-y-scroll input-field)))
(let* ((new-input-field-y-dim (max needed-y-dim
(- (command-buffer-y-dim com-buf)
(length (history-lines-from-history
(command-buffer-y-dim com-buf))))))
(move-input-field (lambda ()
(input-field-move input-field
(input-field-x-location input-field)
(+ (command-buffer-y-loc com-buf)
(- (command-buffer-y-dim com-buf)
new-input-field-y-dim)))))
(resize-input-field (lambda ()
(input-field-resize input-field
buffer-x-dim
new-input-field-y-dim))))
(if (> new-input-field-y-dim (input-field-y-size input-field))
(begin (move-input-field) (resize-input-field))
(begin (resize-input-field) (move-input-field)))
(if (input-field-y-scroll input-field)
(input-field-toggle-y-scroll input-field))))
(set-input-field-text! input-field text))))
(define set-buffer-text! set-command-buffer-text!)
(define change-command-buffer-prompt!
(lambda (com-buf prompt)
(let* ((new-input-field-y-dim (max 1
(- (command-buffer-y-dim com-buf)
(length (history-lines-from-history
(command-buffer-y-dim com-buf))))))
(old-input-field (command-buffer-input-field com-buf))
(text (input-field-text old-input-field)))
(set-command-buffer-prompt! com-buf prompt)
(set-command-buffer-input-field! com-buf
(make&install-input-field
(command-buffer-win com-buf)
(command-buffer-x-loc com-buf)
(+ (command-buffer-y-loc com-buf)
(- (command-buffer-y-dim com-buf)
new-input-field-y-dim))
(command-buffer-x-dim com-buf)
new-input-field-y-dim
(let ((prompt (command-buffer-prompt com-buf)))
(if (procedure? prompt)
(prompt)
prompt))
""
standard-behavior-pro))
(set-command-buffer-text! com-buf text)
(remove-input-field old-input-field))
(print-command-buffer com-buf)))
(define enlarge-input-field
(lambda (com-buf asc)
(let ((input-field (command-buffer-input-field com-buf)))
(if (= (command-buffer-y-dim com-buf)
(input-field-y-size input-field))
(begin
(input-field-toggle-y-scroll input-field)
(send-input-field input-field key-right))
(begin
(input-field-move input-field
(input-field-x-location input-field)
(- (input-field-y-location input-field)
1))
(input-field-resize input-field
(input-field-x-size input-field)
(+ (input-field-y-size input-field)
1))
(send-input-field input-field asc)
(send-input-field input-field key-right)))
(print-command-buffer com-buf))))
(define fill-string
(lambda (str ch len)
(let loop ((len (- len (string-length str)))
(missing '()))
(if (zero? len)
(string-append str
(list->string missing))
(loop (- len 1)
(cons ch missing))))))

124
scheme/nuit-engine.scm
View File

@ -158,31 +158,29 @@
(refresh-result-window))
(else
(focus-command-buffer!)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window))))
(define (current-command-line)
(let ((entered (last (buffer-text (command-buffer)))))
(let ((entered (buffer-text (command-buffer))))
(if (string=? entered "")
#f
entered)))
(define (replace-current-command-line! text)
(set-buffer-text!
(command-buffer)
(reverse
(cons text
(cdr (reverse (buffer-text (command-buffer))))))))
(set-buffer-text! (command-buffer) text))
(define (toggle-command/scheme-mode)
(cond
((command-buffer-in-command-mode?)
(enter-scheme-mode!))
(enter-scheme-mode!)
(change-command-buffer-prompt! (command-buffer) "> "))
((command-buffer-in-scheme-mode?)
(enter-command-mode!)))
(enter-command-mode!)
(change-command-buffer-prompt! (command-buffer) (lambda ()
(string-append (cwd)
"> ")))))
(paint-command-frame-window)
(paint-command-window-contents)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window))
;; assumes we are in command mode
@ -198,17 +196,14 @@
(compile-command-line parsed))))
(replace-current-command-line! scheme-str)
(enter-scheme-mode!)
(set-buffer-pos-col! (command-buffer)
(+ 2 (string-length scheme-str)))
(paint-command-frame-window)
(paint-command-window-contents)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window))))
(else (values)))))
(else (values))))
(define (handle-return-key)
(let ((command-line (cadr (reverse (buffer-text (command-buffer))))))
(let ((command-line (buffer-text (command-buffer))))
(debug-message "command-line " command-line)
(cond
((string=? command-line "")
@ -282,7 +277,6 @@
(paint-active-command-window)
(paint-result-window new-entry)
(refresh-result-window)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(release-lock paint-lock))))
@ -303,7 +297,6 @@
(paint-active-command-window)
(paint-result-window new-entry)
(refresh-result-window)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(release-lock paint-lock))))
@ -315,9 +308,7 @@
(send (current-viewer)
'get-selection-as-text
(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 (command-buffer))
(refresh-command-window)
(refresh-result-window))
@ -329,9 +320,7 @@
(command-buffer-in-scheme-mode?)
(focus-table))
(send (current-viewer) 'get-selection-as-ref (focus-table))))
(print-command-buffer (app-window-curses-win (command-window))
(command-buffer))
(move-cursor (command-buffer) (result-buffer))
(print-command-buffer (command-buffer))
(refresh-command-window)
(refresh-result-window))
@ -375,11 +364,10 @@
(init-windows!)
(read-config-file!)
(set! *command-buffer-mode* (config 'main 'initial-command-mode))
(set-evaluation-package! 'nuit-eval)
(clear)
(if (not (process-group-leader?))
(become-session-leader))
@ -399,11 +387,9 @@
(paint-job-status-list stats)
(paint-command-window-contents)
(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))))))
(paint)
(let loop ((ch (wait-for-input))
(c-x-pressed? #f))
@ -417,7 +403,9 @@
(when (current-history-item)
(paint-result-window
(entry-data (current-history-item)))
(refresh-result-window))))
(refresh-result-window)
(if (focus-on-command-buffer?)
(refresh-command-window)))))
(loop (wait-for-input) c-x-pressed?))
;; Ctrl-x -> wait for next input
((= ch key-control-x)
@ -427,7 +415,7 @@
((and (focus-on-command-buffer?)
(command-buffer-in-command-mode?)
(= ch key-tab))
(offer-completions (last (buffer-text (command-buffer))))
(offer-completions (buffer-text (command-buffer)))
(loop (wait-for-input) #f))
((and (focus-on-command-buffer?)
@ -507,15 +495,13 @@
(loop (wait-for-input) c-x-pressed?))
((and (focus-on-command-buffer?) (= ch 10))
(handle-return-key)
(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))
(print-command-buffer (command-buffer))
(refresh-command-window)
(release-lock paint-lock)
(handle-return-key)
(loop (wait-for-input) c-x-pressed?))
(else
@ -535,7 +521,6 @@
(unset-redisplay-everything)))
(paint-result-window (entry-data (current-history-item)))
(move-cursor (command-buffer) (result-buffer))
(refresh-result-window)
(release-lock paint-lock))
(loop (wait-for-input) #f))
@ -543,9 +528,7 @@
(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))
(print-command-buffer (command-buffer))
(refresh-command-window)
(release-lock paint-lock)
(loop (wait-for-input) c-x-pressed?)))))))
@ -606,13 +589,7 @@
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)))
(print-command-buffer (command-buffer)))
(define (refresh-command-window)
(wrefresh (app-window-curses-win (command-window))))
@ -635,9 +612,7 @@
(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))
(refresh-result-window)
(refresh-command-window))
@ -648,9 +623,11 @@
(paint-active-command-window)
(paint-result-frame-window)
;(paint-result-window)
(move-cursor (command-buffer) (result-buffer))
(refresh-command-window)
(refresh-result-window))
(if (focus-on-command-buffer?)
(begin (refresh-result-window)
(refresh-command-window))
(begin (refresh-command-window)
(refresh-result-window))))
(define (wait-for-input)
(noecho)
@ -672,12 +649,6 @@
(else
(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))
(define (determine-plugin-by-type result)
(find (lambda (r)
@ -687,22 +658,7 @@
;;Management of the upper buffer
;;add a char to the buffer
(define (add-to-command-buffer ch)
(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))
(string-length old-last-el)))
(new-last-el (string-append before-ch
(string (ascii->char ch))
after-ch)))
(set-buffer-text! (command-buffer)
(append old-rest (list new-last-el)))
(set-buffer-pos-col! (command-buffer)
(+ (buffer-pos-col (command-buffer)) 1))))
(input (command-buffer) ch))
;;add a string to the buffer
(define (add-string-to-command-buffer string)
@ -736,21 +692,6 @@
width)))))
(wrefresh win)))
;;Cursor
;;move cursor to the corrct position
(define (move-cursor command-buffer result-buffer)
(cond
((focus-on-command-buffer?)
(cursor-right-pos
(app-window-curses-win (command-window))
command-buffer))
(else
(compute-y-x result-buffer)
(wmove (app-window-curses-win (result-window))
(result-buffer-y result-buffer)
(result-buffer-x result-buffer))
(wrefresh (app-window-curses-win (result-window))))))
;;compue pos-x and pos-y
(define (compute-y-x result-buffer)
(let ((pos-result (result-buffer-line result-buffer))
@ -790,20 +731,14 @@
(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)
(append
(drop-right (buffer-text (command-buffer)) 1)
(list line)))
(set-buffer-text! (command-buffer) 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))
(print-command-buffer (command-buffer))
(refresh-command-window))
(define (current-cursor-index)
;; #### No, I will not comment on this.
(- (buffer-pos-col (command-buffer)) 2))
(buffer-pos-col (command-buffer))) ;; - 2
(define (offer-completions command)
(debug-message "offer-completions '" command "' " (current-cursor-index))
@ -891,4 +826,3 @@
#f)
(else
#f))))))

19
scheme/nuit-packages.scm
View File

@ -144,10 +144,28 @@
rendezvous-channels
ncurses
command-buffer
tty-debug
layout)
(files win))
(define-interface command-buffer-interface
(export make-buffer
buffer-text
set-buffer-text!
change-command-buffer-prompt!
buffer-pos-col
input
print-command-buffer))
(define-structure command-buffer command-buffer-interface
(open scheme-with-scsh
srfi-1
define-record-types
ncurses
history)
(files command-buffer))
;;; process viewer plugin
(define-structure process-viewer
@ -959,6 +977,7 @@
destructuring
(modify ncurses (hide filter))
command-buffer
app-windows
initial-tty
nuit-windows

22
scheme/win.scm
View File

@ -34,13 +34,23 @@
(define *result-frame-window* #f)
(define (result-frame-window) *result-frame-window*)
(define *command-buffer*
(make-buffer '("pwd" "")
2 2 2 1 1
0 0
#t 1))
(define *command-buffer* #f)
; (make-buffer '("pwd" "")
; 2 2 2 1 1
; 0 0
; #t 1))
(define (command-buffer) *command-buffer*)
(define (command-buffer)
(if *command-buffer*
*command-buffer*
(let ((buf (make-buffer (app-window-curses-win (command-window))
(lambda ()
(string-append (cwd) "> "))
0 0
(- (app-window-width (command-window)) 0)
(- (app-window-height (command-window)) 1))))
(set! *command-buffer* buf)
buf)))
(define *result-buffer*
(make-result-buffer 0 0 0 0