405 lines
13 KiB
Scheme
405 lines
13 KiB
Scheme
;; 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 text)
|
|
command-history-entry?
|
|
(prompt command-history-entry-prompt)
|
|
(text command-history-entry-text))
|
|
|
|
(define input-field->command-history-item
|
|
(lambda (input-field)
|
|
(let* ((prompt (input-field-prompt input-field))
|
|
(text (input-field-text input-field)))
|
|
(make-command-history-entry prompt text))))
|
|
|
|
(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
|
|
(command-history-entry-text
|
|
(entry-data *current-command-history-item*))))
|
|
(let ((current-window-text (command-history-entry-text
|
|
(entry-data *current-command-history-item*))))
|
|
(command-history-back!)
|
|
(set-command-buffer-text! com-buf
|
|
(command-history-entry-text
|
|
(entry-data *current-command-history-item*)))
|
|
(if (and (not (eq? *current-command-history-item*
|
|
(history-first-entry (command-history))))
|
|
(equal? current-window-text
|
|
(command-history-entry-text
|
|
(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-text (command-history-entry-text
|
|
(entry-data *current-command-history-item*))))
|
|
(command-history-forward!)
|
|
(set-command-buffer-text! com-buf
|
|
(command-history-entry-text
|
|
(entry-data *current-command-history-item*)))
|
|
(if (equal? current-window-text
|
|
(command-history-entry-text
|
|
(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 (com-buf 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 (apply append
|
|
(map split-string-at-newline
|
|
(split-to-string-list (string-append (command-history-entry-prompt current-item)
|
|
(command-history-entry-text current-item))
|
|
(command-buffer-x-dim com-buf)))))
|
|
(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 com-buf
|
|
(+ (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 ((eq? asc 'input-end)
|
|
(input-end-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 input-end-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
|
|
com-buf
|
|
(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 com-buf
|
|
(+ 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 (how-many-lines-in-command-buffer
|
|
com-buf
|
|
(if prompt
|
|
(string-append prompt text)
|
|
text))))
|
|
; (+ (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
|
|
com-buf
|
|
(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)
|
|
(input-field-refresh input-field))))
|
|
|
|
(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
|
|
com-buf
|
|
(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))
|
|
(input-field-toggle-y-scroll input-field)
|
|
(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 key-right)
|
|
(send-input-field input-field key-down)
|
|
(send-input-field input-field asc))
|
|
(print-command-buffer com-buf)))
|
|
|
|
(define how-many-lines-in-command-buffer
|
|
(lambda (com-buf text)
|
|
(let ((edit-lines (split-string-at-newline text))
|
|
(x-dim (command-buffer-x-dim com-buf)))
|
|
(fold-right + 0
|
|
(map (lambda (str)
|
|
(+ (quotient (string-length str)
|
|
x-dim)
|
|
1))
|
|
edit-lines)))))
|
|
|