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

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

the input to eval.

written by Christoph Hetz
This commit is contained in:
mainzelm 2006-04-05 10:09:24 +00:00
parent ddaa47715f
commit bd45459034
4 changed files with 191 additions and 69 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

111
scheme/command-buffer.scm
View File

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

100
scheme/nuit-engine.scm
View File

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

11
scheme/nuit-packages.scm
View File

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

30
scheme/utils.scm
View File

@ -37,3 +37,33 @@
*redisplay-everything*)
(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)))))