In the scheme mode, wait for a balanced s-expression before sending

the input to eval.

written by Christoph Hetz

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 
+;	   (prompt+texts (map list->string 
-			      (input-field-window-lines input-field)))
+;			      (input-field-window-lines input-field)))
-	   (texts (cons (substring (car prompt+texts)
+;	   (texts (cons (substring (car prompt+texts)
-				   (string-length prompt)
+;				   (string-length prompt)
-				   (string-length (car prompt+texts)))
+;				   (string-length (car prompt+texts)))
-			(cdr prompt+texts)))
+;			(cdr prompt+texts)))
-	   (text (fold-right string-append
+	   (text (input-field-text input-field))) 
-			     ""
+;	     (fold-right string-append
-			     texts)))
+;			     ""
+;			     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)
+		 (new-lines (apply append
-								 (command-history-entry-text current-item))
+                                   (map split-string-at-newline
-						  (command-buffer-x-dim com-buf)))
+                                        (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)
+    (cond ((eq? asc 'input-end)
-	       (= asc 10))
+	   (input-end-action com-buf))	       
-	   (return-pressed-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
+	   (needed-y-dim (how-many-lines-in-command-buffer
-			      (+ (quotient (+ (string-length prompt)
+			  com-buf
-					      (string-length text))
+			  (if prompt
-					   buffer-x-dim)
+			      (string-append prompt text)
-				 1))))
+			      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 
-	(begin 
+	    (input-field-move input-field
-	  (input-field-move input-field
+			      (input-field-x-location input-field)
-			    (input-field-x-location input-field)
+			      (- (input-field-y-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)
+	    (input-field-resize input-field 
-	  (send-input-field input-field key-right)))
+				(input-field-x-size input-field)
-      (print-command-buffer com-buf))))
+				(+ (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))
+(define how-many-lines-in-command-buffer
-	  (let ((new-str (substring str 
+  (lambda (com-buf text)
-				    len str-len)))
+    (let ((edit-lines (split-string-at-newline text))
-	  (loop (append lst (list (substring str
+	  (x-dim (command-buffer-x-dim com-buf)))
-					     0 len)))
+      (fold-right + 0
-		new-str
+		  (map (lambda (str)
-		(string-length new-str)))))))
+			 (+ (quotient (string-length str)
-					     
+				      x-dim)
+			    1))
+		       edit-lines)))))
+

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)))

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)

scheme/utils.scm

@@ -36,4 +36,34 @@
 (define (redisplay-everything?)
   *redisplay-everything*)
 
-(define (identity-function x) x)
+(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)))))