From bd45459034fd8bfb4a5812a864bb9d796cccc5fd Mon Sep 17 00:00:00 2001 From: mainzelm Date: Wed, 5 Apr 2006 10:09:24 +0000 Subject: [PATCH] In the scheme mode, wait for a balanced s-expression before sending the input to eval. written by Christoph Hetz --- scheme/command-buffer.scm | 117 +++++++++++++++++++------------------- scheme/nuit-engine.scm | 100 +++++++++++++++++++++++++++++--- scheme/nuit-packages.scm | 11 +++- scheme/utils.scm | 32 ++++++++++- 4 files changed, 191 insertions(+), 69 deletions(-) diff --git a/scheme/command-buffer.scm b/scheme/command-buffer.scm index 0ea5a84..4b19536 100644 --- a/scheme/command-buffer.scm +++ b/scheme/command-buffer.scm @@ -19,15 +19,16 @@ (define input-field->command-history-item (lambda (input-field) (let* ((prompt (input-field-prompt input-field)) - (prompt+texts (map list->string - (input-field-window-lines input-field))) - (texts (cons (substring (car prompt+texts) - (string-length prompt) - (string-length (car prompt+texts))) - (cdr prompt+texts))) - (text (fold-right string-append - "" - texts))) +; (prompt+texts (map list->string +; (input-field-window-lines input-field))) +; (texts (cons (substring (car prompt+texts) +; (string-length prompt) +; (string-length (car prompt+texts))) +; (cdr prompt+texts))) + (text (input-field-text input-field))) +; (fold-right string-append +; "" +; texts))) (make-command-history-entry prompt text)))) (define (append-to-command-history! history-entry) @@ -69,7 +70,7 @@ (command-history-entry-text (entry-data *current-command-history-item*)))) (let ((current-window-text (command-history-entry-text - (entry-data *current-command-history-item*)))) + (entry-data *current-command-history-item*)))) (command-history-back!) (set-command-buffer-text! com-buf (command-history-entry-text @@ -162,9 +163,11 @@ (not current-entry)) history-lines (let* ((current-item (entry-data current-entry)) - (new-lines (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-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 @@ -218,9 +221,8 @@ (define input (lambda (com-buf asc) - (cond ((or (= asc 13) - (= asc 10)) - (return-pressed-action com-buf)) + (cond ((eq? asc 'input-end) + (input-end-action com-buf)) ((= asc key-up) (history-up com-buf)) ((= asc key-down) @@ -239,7 +241,7 @@ (enlarge-input-field com-buf asc) #t))))))) -(define return-pressed-action +(define input-end-action (lambda (com-buf) (append-to-command-history! (input-field->command-history-item (command-buffer-input-field com-buf))) @@ -270,7 +272,7 @@ 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))) @@ -304,11 +306,15 @@ (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)))) + (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 @@ -378,43 +384,36 @@ (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) + (begin + (input-field-move input-field + (input-field-x-location input-field) + (- (input-field-y-location input-field) 1)) - (send-input-field input-field asc) - (send-input-field input-field key-right))) - (print-command-buffer com-buf)))) + (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 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)))))) -(define split-to-string-list - (lambda (str len) - (let loop ((lst '()) - (str str) - (str-len (string-length str))) - (if (<= str-len len) - (append lst (list str)) - (let ((new-str (substring str - len str-len))) - (loop (append lst (list (substring str - 0 len))) - new-str - (string-length new-str))))))) - \ No newline at end of file + + + + + + +(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))))) + diff --git a/scheme/nuit-engine.scm b/scheme/nuit-engine.scm index 2dc61f6..de39c64 100644 --- a/scheme/nuit-engine.scm +++ b/scheme/nuit-engine.scm @@ -180,8 +180,8 @@ (enter-command-mode!) (change-command-buffer-prompt! (command-buffer) (lambda () (string-append (cwd) - "> ")))) - (paint-command-frame-window)) + "> "))))) + (paint-command-frame-window) (paint-command-window-contents) (refresh-command-window)) @@ -204,16 +204,100 @@ (else (values))))) (else (values)))) +(define (balanced? str) + (let ((len (string-length str))) + (let lp ((i 0) + (open 0) + (in-comment? #f) + (in-string? #f) + (next-is-escaped? #f)) + (if (= i len) + (= open 0) + (let ((ch (string-ref str i))) + (cond ((char=? ch #\newline) (lp (+ i 1) + open + #f + in-string? + #f)) + (in-comment? (lp (+ i 1) + open + in-comment? + in-string? + #f)) + (next-is-escaped? (lp (+ i 1) + open + in-comment? + in-string? + #f)) + (in-string? (case ch + ((#\") (lp (+ i 1) + open + in-comment? + #f + #f)) + ((#\\) (lp (+ i 1) + open + in-comment? + in-string? + #t)) + (else (lp (+ i 1) + open + in-comment? + in-string? + #f)))) + (else + (case ch + ((#\") (lp (+ i 1) + open + #f + #t + #f)) + ((#\;) (lp (+ i 1) + open + #t + #f + #f)) + ((#\\) (lp (+ i 1) + open + #f + #f + #t)) + ((#\() (lp (+ i 1) + (+ open 1) + in-comment? + in-string? + next-is-escaped?)) + ((#\)) (if (= open 0) + #f ;; actually a syntax error + (lp (+ i 1) + (- open 1) + in-comment? + in-string? + next-is-escaped?))) + ;; TODO: handle strings and chars + (else (lp (+ i 1) + open + in-comment? + in-string? + next-is-escaped?)))))))))) + + (define (handle-return-key) (let ((command-line (buffer-text (command-buffer)))) (debug-message "command-line " command-line) (cond ((string=? command-line "") + (input (command-buffer) 'input-end) (values)) ((command-buffer-in-scheme-mode?) - (eval-command-in-scheme-mode command-line)) + (if (balanced? command-line) + (begin + (eval-command-in-scheme-mode command-line) + (input (command-buffer) 'input-end)) + (input (command-buffer) 10))) ((command-buffer-in-command-mode?) - (eval-command-in-command-mode command-line)) + (eval-command-in-command-mode command-line) + (input (command-buffer) 'input-end)) (else (error "Cannot handle return key" command-line))))) @@ -513,7 +597,7 @@ ((and (focus-on-command-buffer?) (= ch 10)) (handle-return-key) - (input (command-buffer) ch) + ;(input (command-buffer) ch) (obtain-lock paint-lock) (werase (app-window-curses-win (command-window))) (print-command-buffer (command-buffer)) @@ -689,7 +773,7 @@ ;;; FIXME: I guess s48 knows a better way to do this (see ,inspect) (define (maybe-shorten-string string width) (if (> (string-length string) width) - (string-append (substring string 0 (- width 3)) + (string-append (substring string 0 (- width 6)) ;;was too long (was 3) "...") string)) @@ -704,7 +788,9 @@ (mvwaddstr win 1 2 (maybe-shorten-string (if (history-entry-command (entry-data entry)) - (history-entry-command (entry-data entry)) + (replace-in-string + (history-entry-command (entry-data entry)) + #\newline #\space) "user interaction") width))))) (wrefresh win))) diff --git a/scheme/nuit-packages.scm b/scheme/nuit-packages.scm index 0dc318b..1a5e811 100644 --- a/scheme/nuit-packages.scm +++ b/scheme/nuit-packages.scm @@ -17,12 +17,18 @@ set-redisplay-everything unset-redisplay-everything - redisplay-everything?)) + redisplay-everything? + + replace-in-string + fill-string + split-to-string-list + split-string-at-newline)) (define-structure utils utils-interface (open scheme srfi-6 - (subset srfi-13 (string-join)) + (subset srfi-13 (string-join string-tokenize string-map)) + srfi-14 formats) (files utils)) @@ -161,6 +167,7 @@ (define-structure command-buffer command-buffer-interface (open scheme-with-scsh srfi-1 + utils define-record-types ncurses history) diff --git a/scheme/utils.scm b/scheme/utils.scm index 723593a..4debe24 100644 --- a/scheme/utils.scm +++ b/scheme/utils.scm @@ -36,4 +36,34 @@ (define (redisplay-everything?) *redisplay-everything*) -(define (identity-function x) x) \ No newline at end of file +(define (identity-function x) x) + +(define replace-in-string + (lambda (str ch1 ch2) + (string-map (lambda (ch) + (if (char=? ch ch1) + ch2 + ch)) + str))) + +(define fill-string + (lambda (str ch len) + (let ((missing-len (- len (string-length str)))) + (if (zero? missing-len) + str + (string-append str + (make-string missing-len ch)))))) + +(define split-to-string-list + (lambda (str len) + (let ((str-len (string-length str))) + (let loop ((lst '()) + (start 0)) + (if (<= (- str-len start) len) + (reverse (cons (substring str start str-len) lst)) + (loop (cons (substring str start (+ start len)) lst) + (+ start len))))))) + +(define split-string-at-newline + (lambda (str) + (string-tokenize str (char-set-complement (char-set #\newline))))) \ No newline at end of file