3055 lines
116 KiB
Scheme
3055 lines
116 KiB
Scheme
;;; expeditor.ss
|
|
;;; R. Kent Dybvig
|
|
;;; August 2007
|
|
|
|
;;; This code is based on David Boyer's command-line editor, which has the
|
|
;;; following copyright:
|
|
;;;
|
|
;;; Copyright (c) 1989, 1993, 1994 C. David Boyer
|
|
;;;
|
|
;;; Permission to copy this software, in whole or in part, to use this
|
|
;;; software for any lawful purpose, and to redistribute this software is
|
|
;;; granted subject to the restriction that all copies made of this software
|
|
;;; must include this copyright notice in full.
|
|
;;;
|
|
;;; The present implementation retains some of the basic design but little
|
|
;;; of the original code.
|
|
|
|
;;; The expression editor module is organized into sections:
|
|
;;;
|
|
;;; 1. screen-management routines
|
|
;;; 2. exported parameters
|
|
;;; 3. eestate and pos record definitions
|
|
;;; 4. current entry management routines
|
|
;;; 5. the reader and prompt-and-reader
|
|
;;; 6. history management routines
|
|
;;; 7. key function definitions
|
|
;;; 8. key binding code
|
|
;;;
|
|
;;; Also contained within this file are a few system entry points:
|
|
;;; the $enable-expeditor and $expeditor-history-file parameters and
|
|
;;; the main entry point into the expression editor, $expeditor.
|
|
|
|
(when-feature expeditor
|
|
|
|
(define $enable-expeditor (make-parameter #f))
|
|
(define $expeditor-history-file
|
|
(make-parameter #f
|
|
(lambda (s)
|
|
(cond
|
|
[(not s) s]
|
|
[(string? s)
|
|
(if (string=? s "")
|
|
(if-feature windows
|
|
(cond
|
|
[(getenv "APPDATA") =>
|
|
(lambda (appdata)
|
|
(let ([dir (format "~a\\Chez Scheme" appdata)])
|
|
(unless (file-exists? dir)
|
|
(guard (c [#t (void)]) (mkdir dir)))
|
|
(format "~a\\History" dir)))]
|
|
[(getenv "HOME") =>
|
|
(lambda (home)
|
|
(format "~a\\.chezscheme_history" home))]
|
|
[else ".chezscheme_history"])
|
|
"~/.chezscheme_history")
|
|
s)]
|
|
[else ($oops '$expeditor-history-file "~s is not #f or a string" s)]))))
|
|
|
|
(define $expeditor)
|
|
|
|
(module expression-editor
|
|
(
|
|
; parameters
|
|
ee-auto-indent ee-auto-paren-balance ee-common-identifiers
|
|
ee-default-repeat ee-flash-parens ee-noisy
|
|
ee-paren-flash-delay ee-history-limit ee-standard-indent
|
|
; establishing key bindings
|
|
ee-bind-key ee-compose
|
|
; built-in operators
|
|
ee-next-id-completion
|
|
ee-next-id-completion/indent
|
|
ee-id-completion ee-id-completion/indent
|
|
ee-insert-self ee-command-repeat
|
|
ee-history-bwd ee-history-fwd
|
|
ee-history-fwd-prefix ee-history-bwd-prefix
|
|
ee-history-fwd-contains ee-history-bwd-contains
|
|
ee-newline ee-accept ee-newline/accept ee-open-line
|
|
ee-indent ee-indent-all ee-backward-char
|
|
ee-forward-char ee-next-line ee-previous-line
|
|
ee-end-of-line ee-beginning-of-line
|
|
ee-beginning-of-entry ee-end-of-entry
|
|
ee-delete-to-eol ee-delete-line
|
|
ee-delete-between-point-and-mark ee-set-mark
|
|
ee-delete-entry ee-reset-entry ee-delete-sexp ee-backward-delete-sexp
|
|
ee-redisplay ee-yank-kill-buffer ee-yank-selection
|
|
ee-string-macro ee-eof ee-delete-char ee-eof/delete-char
|
|
ee-backward-delete-char ee-insert-paren
|
|
ee-flash-matching-delimiter ee-goto-matching-delimiter
|
|
ee-exchange-point-and-mark ee-forward-sexp
|
|
ee-backward-sexp ee-forward-word
|
|
ee-backward-word ee-forward-page
|
|
ee-backward-page ee-suspend-process
|
|
)
|
|
|
|
(define-syntax assert*
|
|
(syntax-rules ()
|
|
[(_ expr ...)
|
|
(begin (assert expr) ...)]))
|
|
|
|
(define-syntax on-error
|
|
(syntax-rules ()
|
|
[(on-error e0 e1 e2 ...)
|
|
(guard (c [#t e0]) e1 e2 ...)]))
|
|
|
|
(define-syntax defopt
|
|
(syntax-rules ()
|
|
[(_ (p x ... [y e]) b1 b2 ...)
|
|
(define p
|
|
(case-lambda
|
|
[(x ...) (p x ... e)]
|
|
[(x ... y) b1 b2 ...]))]))
|
|
|
|
; screen initialization and manipulation routines
|
|
|
|
(module (init-screen raw-mode no-raw-mode
|
|
screen-resize! screen-rows screen-cols
|
|
ee-winch? ee-char-ready? ee-peek-char ee-read-char
|
|
ee-write-char ee-display-string ee-flush
|
|
move-cursor-up move-cursor-right move-cursor-left move-cursor-down
|
|
scroll-reverse clear-eol clear-eos clear-screen
|
|
carriage-return line-feed
|
|
bell pause get-clipboard wait)
|
|
; screen state
|
|
(define cols)
|
|
(define rows)
|
|
(define cursor-col)
|
|
(define the-unread-char)
|
|
(define winch)
|
|
|
|
; we use terminfo routines directly, rather than going through curses,
|
|
; because curses requires initscr(), which clears the screen, discarding
|
|
; the current context. this is a shell, not a full-screen user interface.
|
|
|
|
(define init-term (foreign-procedure "(cs)ee_init_term" () boolean))
|
|
(define $ee-read-char (foreign-procedure "(cs)ee_read_char" (boolean) scheme-object))
|
|
(define $ee-write-char (foreign-procedure "(cs)ee_write_char" (wchar_t) void))
|
|
(define ee-flush (foreign-procedure "(cs)ee_flush" () void))
|
|
(define get-screen-size (foreign-procedure "(cs)ee_get_screen_size" () scheme-object))
|
|
(define raw-mode (foreign-procedure "(cs)ee_raw" () void))
|
|
(define no-raw-mode (foreign-procedure "(cs)ee_noraw" () void))
|
|
(define enter-am-mode (foreign-procedure "(cs)ee_enter_am_mode" () void))
|
|
(define exit-am-mode (foreign-procedure "(cs)ee_exit_am_mode" () void))
|
|
(define nanosleep (foreign-procedure "(cs)ee_nanosleep" (unsigned-32 unsigned-32) void))
|
|
(define pause (foreign-procedure "(cs)ee_pause" () void))
|
|
(define get-clipboard (foreign-procedure "(cs)ee_get_clipboard" () scheme-object))
|
|
|
|
(define move-cursor-up (foreign-procedure "(cs)ee_up" (integer-32) void))
|
|
(define move-cursor-down (foreign-procedure "(cs)ee_down" (integer-32) void))
|
|
(define $move-cursor-left (foreign-procedure "(cs)ee_left" (integer-32) void))
|
|
(define $move-cursor-right (foreign-procedure "(cs)ee_right" (integer-32) void))
|
|
(define clear-eol (foreign-procedure "(cs)ee_clr_eol" () void))
|
|
(define clear-eos (foreign-procedure "(cs)ee_clr_eos" () void))
|
|
(define $clear-screen (foreign-procedure "(cs)ee_clear_screen" () void))
|
|
(define scroll-reverse (foreign-procedure "(cs)ee_scroll_reverse" (integer-32) void))
|
|
(define bell (foreign-procedure "(cs)ee_bell" () void))
|
|
(define $carriage-return (foreign-procedure "(cs)ee_carriage_return" () void))
|
|
(define line-feed (foreign-procedure "(cs)ee_line_feed" () void))
|
|
|
|
(define (screen-resize!)
|
|
(let ([p (get-screen-size)])
|
|
(set! rows (car p))
|
|
(set! cols (cdr p))))
|
|
|
|
(define (screen-rows) rows)
|
|
(define (screen-cols) cols)
|
|
|
|
(define (init-screen)
|
|
(and (init-term)
|
|
(begin
|
|
(set! cursor-col 0)
|
|
(set! the-unread-char #f)
|
|
(set! winch #f)
|
|
#t)))
|
|
|
|
(define (clear-screen)
|
|
($clear-screen)
|
|
(set! cursor-col 0))
|
|
|
|
(define (ee-winch?)
|
|
(and (not the-unread-char)
|
|
(if winch
|
|
(begin (set! winch #f) #t)
|
|
(begin
|
|
(ee-flush)
|
|
(let ([c ($ee-read-char #t)])
|
|
(or (eq? c #t)
|
|
(begin (set! the-unread-char c) #f)))))))
|
|
|
|
(define (ee-char-ready?)
|
|
(if the-unread-char
|
|
#t
|
|
(let f ()
|
|
(ee-flush)
|
|
(let ([c ($ee-read-char #f)])
|
|
(cond
|
|
[(eq? c #f) #f]
|
|
[(eq? c #t) (set! winch #t) (f)]
|
|
[else (set! the-unread-char c) #t])))))
|
|
|
|
(define (ee-read-char)
|
|
(if the-unread-char
|
|
(let ([c the-unread-char]) (set! the-unread-char #f) c)
|
|
(let f ()
|
|
(ee-flush)
|
|
(let ([c ($ee-read-char #t)])
|
|
(if (eq? c #t)
|
|
(begin (set! winch #t) (f))
|
|
c)))))
|
|
|
|
(define (ee-peek-char)
|
|
(or the-unread-char
|
|
(let ([c (ee-read-char)])
|
|
(set! the-unread-char c)
|
|
c)))
|
|
|
|
; we assume that ee-write-char receives only characters that occupy one
|
|
; screen cell. it should never be passed #\return, #\newline, or #\tab.
|
|
; furthermore, ee-write-char should never be used to write past the end
|
|
; of a screen line.
|
|
(define (ee-write-char c)
|
|
(set! cursor-col (fx+ cursor-col 1))
|
|
(if (fx= cursor-col cols)
|
|
(begin
|
|
(exit-am-mode)
|
|
($ee-write-char c)
|
|
(enter-am-mode))
|
|
($ee-write-char c)))
|
|
|
|
; comments regarding ee-write-char above apply also to ee-display-string
|
|
(define (ee-display-string s)
|
|
(let ([n (string-length s)])
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i n))
|
|
(ee-write-char (string-ref s i)))))
|
|
|
|
(define (carriage-return)
|
|
(set! cursor-col 0)
|
|
($carriage-return))
|
|
|
|
(define (move-cursor-right n)
|
|
(cond
|
|
[(fx< (fx+ cursor-col n) cols)
|
|
($move-cursor-right n)
|
|
(set! cursor-col (fx+ cursor-col n))]
|
|
[else
|
|
(move-cursor-down (quotient (fx+ cursor-col n) cols))
|
|
(let ([new-cursor-col (remainder (fx+ cursor-col n) cols)])
|
|
(if (fx>= new-cursor-col cursor-col)
|
|
(move-cursor-right (fx- new-cursor-col cursor-col))
|
|
(move-cursor-left (fx- cursor-col new-cursor-col))))]))
|
|
|
|
(define (move-cursor-left n)
|
|
(when (and (fx= cursor-col cols) (fx> n 0))
|
|
(set! n (fx- n 1))
|
|
(set! cursor-col (fx- cursor-col 1)))
|
|
(cond
|
|
[(fx<= n cursor-col)
|
|
($move-cursor-left n)
|
|
(set! cursor-col (fx- cursor-col n))]
|
|
[else
|
|
(move-cursor-up (fx1+ (quotient (fx- n cursor-col 1) cols)))
|
|
(let ([new-cursor-col (remainder
|
|
(fx- cols (remainder (fx- n cursor-col) cols))
|
|
cols)])
|
|
(if (fx>= new-cursor-col cursor-col)
|
|
(move-cursor-right (fx- new-cursor-col cursor-col))
|
|
(move-cursor-left (fx- cursor-col new-cursor-col))))]))
|
|
|
|
(define wait
|
|
(lambda (ms)
|
|
(unless (or (<= ms 0) (ee-char-ready?))
|
|
(nanosleep 0 (* 10 1000 1000)) ; 10ms granularity is best we can assume
|
|
(wait (- ms 10)))))
|
|
)
|
|
|
|
;;; parameters
|
|
|
|
(define ee-common-identifiers
|
|
(make-parameter
|
|
; general theory: exclude short ids and ids that will come up early
|
|
; in an alphabetical search with short prefix. include common ids that
|
|
; come up annoyingly late in such a search.
|
|
'(append apply call/cc call-with-values define display display-string
|
|
define-syntax define-record null? quote quotient reverse read-char
|
|
substring string-ref string-length string? string=? string-set!
|
|
syntax-case syntax-rules unless vector-ref vector-length vector?
|
|
vector-set! vector)
|
|
(lambda (x)
|
|
(unless (and (list? x) (andmap symbol? x))
|
|
($oops 'ee-common-identifiers "~s is not a list of symbols" x))
|
|
x)))
|
|
|
|
;;; default repeat value for ^U
|
|
(define ee-default-repeat
|
|
(make-parameter 4
|
|
(lambda (x)
|
|
(unless (and (fixnum? x) (fxnonnegative? x))
|
|
($oops 'ee-default-repeat "~s is not an integer" x))
|
|
x)))
|
|
|
|
(define ee-auto-indent (make-parameter #t (lambda (x) (and x #t))))
|
|
|
|
(define ee-auto-paren-balance (make-parameter #t (lambda (x) (and x #t))))
|
|
|
|
(define ee-flash-parens (make-parameter #t (lambda (x) (and x #t))))
|
|
|
|
;;; paren balance delay factor in milliseconds
|
|
(define ee-paren-flash-delay
|
|
(make-parameter 100
|
|
(lambda (x)
|
|
(unless (and (fixnum? x) (fxnonnegative? x))
|
|
($oops 'ee-paren-flash-delay "~s is not an integer" x))
|
|
x)))
|
|
|
|
;;; enable/disable bell
|
|
(define ee-noisy (make-parameter #f (lambda (x) (and x #t))))
|
|
|
|
;;; standard indent length
|
|
(define ee-standard-indent
|
|
(make-parameter 2
|
|
(lambda (x)
|
|
(unless (and (fixnum? x) (fxnonnegative? x))
|
|
($oops 'ee-standard-indent "~s is not an integer" x))
|
|
x)))
|
|
|
|
(define ee-history-limit
|
|
(make-parameter 256
|
|
(lambda (x)
|
|
(unless (and (fixnum? x) (fxnonnegative? x))
|
|
($oops 'ee-history-length "~s is not a nonnegative fixnum" x))
|
|
x)))
|
|
|
|
;;; eestate holds the state of the expression editor.
|
|
|
|
(define-record-type eestate
|
|
(fields
|
|
(mutable last-op)
|
|
(mutable rt-last-op)
|
|
(mutable prompt)
|
|
(mutable repeat-count)
|
|
(mutable killbuf)
|
|
(mutable histnew)
|
|
(mutable histbwd)
|
|
(mutable histnow)
|
|
(mutable histfwd)
|
|
(mutable histkey)
|
|
(mutable last-suffix*)
|
|
(mutable cc?))
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(protocol
|
|
(lambda (new)
|
|
(lambda ()
|
|
(new #f ; last-op
|
|
'(0 . 0) ; rt-last-op
|
|
"" ; prompt
|
|
1 ; repeat-count
|
|
'() ; killbuf
|
|
0 ; histnew
|
|
'() ; histbwd
|
|
"" ; histnow
|
|
'() ; hisfwd
|
|
"" ; histkey
|
|
'() ; last-suffix*
|
|
#f))))) ; cc?
|
|
|
|
(module ()
|
|
(record-writer (type-descriptor eestate)
|
|
(lambda (x p wr)
|
|
(display "#<ee-state>" p))))
|
|
|
|
;;; pos is used for two different but related purposes: for row, col
|
|
;;; positions and for row, physical-line positions. see the comment
|
|
;;; about the entry top-line and bot-line fields below.
|
|
|
|
(module (make-pos pos? pos-row pos-col pos=? pos<? pos<=? pos>? pos>=? index->pos)
|
|
(define-record-type pos
|
|
(fields (immutable row) (immutable col))
|
|
(nongenerative)
|
|
(sealed #t))
|
|
(define (pos=? p1 p2)
|
|
(and (fx= (pos-row p1) (pos-row p2))
|
|
(fx= (pos-col p1) (pos-col p2))))
|
|
(define (pos<? p1 p2)
|
|
(or (fx< (pos-row p1) (pos-row p2))
|
|
(and (fx= (pos-row p1) (pos-row p2))
|
|
(fx< (pos-col p1) (pos-col p2)))))
|
|
(define (pos<=? p1 p2)
|
|
(or (fx< (pos-row p1) (pos-row p2))
|
|
(and (fx= (pos-row p1) (pos-row p2))
|
|
(fx<= (pos-col p1) (pos-col p2)))))
|
|
(define (pos>? p1 p2)
|
|
(or (fx> (pos-row p1) (pos-row p2))
|
|
(and (fx= (pos-row p1) (pos-row p2))
|
|
(fx> (pos-col p1) (pos-col p2)))))
|
|
(define (pos>=? p1 p2)
|
|
(or (fx> (pos-row p1) (pos-row p2))
|
|
(and (fx= (pos-row p1) (pos-row p2))
|
|
(fx>= (pos-col p1) (pos-col p2)))))
|
|
(define (index->pos s n r c)
|
|
; convert index in single-string representation of entry
|
|
; into pos. r and c are row and col at which string
|
|
; starts in the entry
|
|
(let f ([i 0] [r r] [c c])
|
|
(if (fx= i n)
|
|
(make-pos r c)
|
|
(if (char=? (string-ref s i) #\newline)
|
|
(f (fx+ i 1) (fx+ r 1) 0)
|
|
(f (fx+ i 1) r (fx+ c 1))))))
|
|
(record-writer (type-descriptor pos)
|
|
(lambda (x p wr)
|
|
(fprintf p "#<pos ~a ~a>" (pos-row x) (pos-col x))))
|
|
)
|
|
|
|
(define lpchar #\()
|
|
(define rpchar #\))
|
|
(define lbchar #\[)
|
|
(define rbchar #\])
|
|
|
|
(define beep
|
|
(lambda (str . arg*)
|
|
#;(with-output-to-file "/tmp/ee.log"
|
|
(lambda () (apply printf str arg*) (newline))
|
|
'append)
|
|
(when (ee-noisy) (bell))))
|
|
|
|
(module (string->entry
|
|
entry->string
|
|
string->lines
|
|
; primtiive and derived record accessors and mutators: no ee argument
|
|
entry-col
|
|
entry-nsr
|
|
entry-row
|
|
entry-mark
|
|
entry-point
|
|
null-entry?
|
|
entry-mark-set!
|
|
entry-row-set!
|
|
entry-col-set!
|
|
; normal entry procedures: first two arguments are ee and entry
|
|
add-char
|
|
beginning-of-line?
|
|
clear-entry
|
|
id-completions
|
|
correct&flash-matching-delimiter
|
|
yank-entry
|
|
delete-char
|
|
delete-forward
|
|
delete-to-eol
|
|
echo-entry
|
|
end-of-line?
|
|
find-matching-delimiter
|
|
find-next-sexp-backward
|
|
find-next-sexp-forward
|
|
find-next-word
|
|
find-previous-word
|
|
first-line?
|
|
flash
|
|
goto
|
|
handle-winch
|
|
indent
|
|
indent-all
|
|
insert-string-before
|
|
insert-strings-before
|
|
join-rows
|
|
last-line?
|
|
last-line-displayed?
|
|
move-bol
|
|
move-down
|
|
move-eoe
|
|
move-eol
|
|
move-left
|
|
move-right
|
|
move-up
|
|
only-whitespace-left?
|
|
page-down
|
|
page-up
|
|
redisplay
|
|
should-auto-indent?)
|
|
|
|
; NB. top-line and bot-line aren't really positions.
|
|
; the row does identify the logical row, but the col identifies the
|
|
; physical row of the logical row, i.e., 0 for the first physical
|
|
; row, 1 for the second, etc.
|
|
|
|
(define-record-type entry
|
|
(fields
|
|
(immutable lns) ; logical lines
|
|
(mutable row) ; point (logical cursor) row
|
|
(mutable col) ; point (logical cursor) column
|
|
(mutable screen-cols) ; cached screen columns
|
|
(mutable screen-rows) ; cached screen rows
|
|
(mutable top-line) ; first displayed line
|
|
(mutable bot-line) ; last displayed line
|
|
(mutable mark)) ; current mark pos
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(protocol
|
|
(lambda (new)
|
|
(lambda (lns)
|
|
(new lns 0 0 (screen-cols) (screen-rows)
|
|
(make-pos 0 0) (make-pos 0 0) #f)))))
|
|
|
|
(module ()
|
|
(record-writer (type-descriptor entry)
|
|
(lambda (x p wr)
|
|
(display "#<ee entry>" p))))
|
|
|
|
(define (entry-point entry)
|
|
(make-pos (entry-row entry) (entry-col entry)))
|
|
|
|
;;; an lns is a nonempty list of logical lines, each of which may span
|
|
;;; multiple screen lines. each line consists of an integer that records
|
|
;;; the number of screen rows spanned along with a string containing
|
|
;;; the text of the line. lines are implicitly separated by newlines; no
|
|
;;; newlines appear in the strings themselves.
|
|
;;;
|
|
;;; lns := (ln ln ...) ;;; list of "ln"s
|
|
;;; ln := [nsr, str]
|
|
;;; nsr := integer ;;; number of screen rows occupied by the line
|
|
;;; str := string ;;; contents of the line
|
|
|
|
; arrange for nsr to be updated whenever str is changed
|
|
(module (make-ln ln? ln-str ln-nsr ln-str-set! ln-nsr-set!)
|
|
(define-record-type (ln make-ln ln?)
|
|
(fields
|
|
(mutable str ln-str $ln-str-set!)
|
|
(mutable nsr ln-nsr ln-nsr-set!))
|
|
(nongenerative)
|
|
(sealed #t)
|
|
(protocol
|
|
(lambda (new)
|
|
(lambda (ee str)
|
|
(new str (str->nsr ee str))))))
|
|
(define (ln-str-set! ee ln str)
|
|
($ln-str-set! ln str)
|
|
(ln-nsr-set! ln (str->nsr ee str))))
|
|
|
|
; extract nsr or str from selected row of lns
|
|
(define (lns->nsr lns row) (ln-nsr (list-ref lns row)))
|
|
(define (lns->str lns row) (ln-str (list-ref lns row)))
|
|
|
|
; replace str in selected row of lns
|
|
(define (lns->str! ee lns row str)
|
|
(ln-str-set! ee (list-ref lns row) str))
|
|
|
|
(define (lns->char lns row col)
|
|
(let ([str (lns->str lns row)])
|
|
(if (fx< col (string-length str))
|
|
(string-ref str col)
|
|
#f)))
|
|
|
|
(define (yank-entry ee entry)
|
|
(map ln-str (entry-lns entry)))
|
|
|
|
(define (entry->string entry)
|
|
(let* ([lns (entry-lns entry)] [n (length lns)])
|
|
(let ([sop (open-output-string)])
|
|
(let loop ([i 0] [sep ""])
|
|
(unless (fx= i n)
|
|
(fprintf sop "~a~a" sep (lns->str lns i))
|
|
(loop (fx+ i 1) "\n")))
|
|
(get-output-string sop))))
|
|
|
|
(define (echo-entry ee entry tp)
|
|
(display-string (eestate-prompt ee) tp)
|
|
(let ([lns (entry-lns entry)])
|
|
(fprintf tp "~a\n" (ln-str (car lns)))
|
|
(for-each
|
|
(let ([pad (phantom-prompt ee)])
|
|
(lambda (ln) (fprintf tp "~a~a\n" pad (ln-str ln))))
|
|
(cdr lns)))
|
|
(flush-output-port tp))
|
|
|
|
(define (string->lines s)
|
|
; break string into list of lines while expanding tabs
|
|
(let ([n (string-length s)] [op (open-output-string)])
|
|
(let f ([i 0] [col 0])
|
|
(if (fx= i n)
|
|
(list (get-output-string op))
|
|
(let ([c (string-ref s i)])
|
|
(case c
|
|
[(#\newline)
|
|
(let ([line (get-output-string op)])
|
|
(cons line (f (fx+ i 1) 0)))]
|
|
[(#\tab)
|
|
(do ([i (fx- 8 (fxmodulo col 8)) (fx- i 1)])
|
|
((fx= i 0))
|
|
(write-char #\space op))
|
|
(f (fx+ i 1) 0)]
|
|
[(#\return) (f (fx+ i 1) col)]
|
|
[else (write-char c op) (f (fx+ i 1) (fx+ col 1))]))))))
|
|
|
|
(define (string->entry ee s)
|
|
(let ([ln* (map (lambda (str) (make-ln ee str)) (string->lines s))])
|
|
(make-entry (if (null? ln*) (list (make-ln ee "")) ln*))))
|
|
|
|
(define (null-entry? entry)
|
|
(let ([lns (entry-lns entry)])
|
|
(and (fx= (length lns) 1)
|
|
(equal? (ln-str (car lns)) ""))))
|
|
|
|
(define (entry-nsr entry) (apply fx+ (map ln-nsr (entry-lns entry))))
|
|
|
|
;;; split a logical row into a list of strings each of which will fit
|
|
;;; on a screen line, starting at logical column col.
|
|
(define split-string
|
|
(lambda (ee str col)
|
|
(let ([str-len (string-length str)])
|
|
(let f ([col col] [width (fx- (screen-cols) (col->screen-col ee col))])
|
|
(if (fx< (fx- str-len col) width)
|
|
(list (substring str col str-len))
|
|
(cons (substring str col (fx+ col width))
|
|
(f (fx+ col width) (screen-cols))))))))
|
|
|
|
(define (screen-lines-between ee entry toprow topoff nextrow nextoff)
|
|
; returns distance in physical screen lines between physical line
|
|
; topoff of toprow and nextoff of nextrow
|
|
(let ([lns (entry-lns entry)])
|
|
(let f ([i toprow] [off topoff] [lns (list-tail lns toprow)])
|
|
(if (fx= i nextrow)
|
|
(fx- nextoff off)
|
|
(fx+ (fx- (ln-nsr (car lns)) off)
|
|
(f (fx+ i 1) 0 (cdr lns)))))))
|
|
|
|
(define (str->nsr ee str)
|
|
(fx+ (col->line-offset ee (string-length str)) 1))
|
|
|
|
;;; return the line offset based on the column and screen size
|
|
;;; ||-offset=2 (prompt)
|
|
;;; example: if: col = 15 vv
|
|
;;; offset = 2 -----------
|
|
;;; scrn-cols = 10 |> line-000| line-offset 0
|
|
;;; then: |line-11111| line-offset 1
|
|
;;; line-offset = 1 ^column = 15
|
|
(define col->line-offset
|
|
(lambda (ee col)
|
|
(fxquotient (fx+ (string-length (eestate-prompt ee)) col) (screen-cols))))
|
|
|
|
;;; return the actual screen column based on the logical row column
|
|
;;; example: if: col = 15 vv-offset=2 (prompt)
|
|
;;; offset = 2 -----------
|
|
;;; scrn-cols = 10 |> line-000| line-offset 0
|
|
;;; then: |line-11111| line-offset 1
|
|
;;; scrn-col = 7 ^column = 15
|
|
(define col->screen-col
|
|
(lambda (ee col)
|
|
(fxremainder (fx+ col (string-length (eestate-prompt ee))) (screen-cols))))
|
|
|
|
(define (clear-entry ee entry)
|
|
; like clear-screen, but clears only from top line of entry
|
|
(if (visible? ee entry 0 0)
|
|
(begin
|
|
(carriage-return)
|
|
(move-cursor-up
|
|
(let ([top-line (entry-top-line entry)])
|
|
(screen-lines-between ee entry
|
|
(pos-row top-line) (pos-col top-line)
|
|
(entry-row entry) (col->line-offset ee (entry-col entry)))))
|
|
(clear-eos))
|
|
(clear-screen)))
|
|
|
|
;;; given bottom line displayed, determines top line that will fill
|
|
;;; the screen to the extent possible
|
|
(defopt (calc-top-line-displayed entry last-row-pos [nrows (screen-rows)])
|
|
(let ([lns (entry-lns entry)])
|
|
(let loop ([n nrows]
|
|
[r (pos-row last-row-pos)]
|
|
[off (pos-col last-row-pos)])
|
|
(if (or (fx= n 1) (and (fx= r 0) (fx= off 0)))
|
|
(make-pos r off)
|
|
(if (fx= off 0)
|
|
(loop (fx- n 1) (fx- r 1) (fx- (lns->nsr lns (fx- r 1)) 1))
|
|
(loop (fx- n 1) r (fx- off 1)))))))
|
|
|
|
;;; given first line displayed, determines bottom line that will fill
|
|
;;; the screen to the extent possible
|
|
(defopt (calc-bot-line-displayed entry first-row-pos [nrows (screen-rows)])
|
|
(let* ([lns (entry-lns entry)]
|
|
[last-row (fx- (length lns) 1)]
|
|
[last-off (fx- (lns->nsr lns last-row) 1)]
|
|
[first-row (pos-row first-row-pos)])
|
|
(let loop ([n nrows]
|
|
[r first-row]
|
|
[off (pos-col first-row-pos)]
|
|
[off-max (fx- (lns->nsr lns first-row) 1)])
|
|
(if (or (fx= n 1) (and (fx= r last-row) (fx= off last-off)))
|
|
(make-pos r off)
|
|
(if (fx= off off-max)
|
|
(loop (fx- n 1) (fx+ r 1) 0 (fx- (lns->nsr lns (fx+ r 1)) 1))
|
|
(loop (fx- n 1) r (fx+ off 1) off-max))))))
|
|
|
|
; NB. the macos x terminal app distinguishes between empty screen
|
|
; positions (e.g., after clr_eos or clr_eol) and screen positions filled
|
|
; with spaces. attempts to move past and clear after the former result
|
|
; in strange behavior. (For example, the sequence clr_eos, cursor_right,
|
|
; clr_eol, 'a', clr_eol, and 'b' doesn't print the b but does cause the
|
|
; terminal to send back some characters. Using ' ' in place of the
|
|
; cursor_right works as expected.) For this reason, we display spaces
|
|
; and avoid using move-cursor-right to pad the front of each row after
|
|
; the first, which gets the actual prompt.
|
|
|
|
(define (phantom-prompt ee)
|
|
(make-string (string-length (eestate-prompt ee)) #\space))
|
|
|
|
(module (display-rest/goto)
|
|
(define (display-rest-of-line ee entry row col clear?)
|
|
; display as much of the rest of row as will fit on the screen
|
|
(let ([lns (entry-lns entry)] [bot-line (entry-bot-line entry)])
|
|
; n = number of lines to display beyond the first
|
|
(let loop ([n (fx- (if (fx= row (pos-row bot-line))
|
|
(pos-col bot-line)
|
|
(fx- (lns->nsr lns row) 1))
|
|
(col->line-offset ee col))]
|
|
[str-lst (split-string ee (lns->str lns row) col)]
|
|
[new-col col])
|
|
(when clear? (clear-eol))
|
|
(let ([str (car str-lst)])
|
|
(ee-display-string (car str-lst))
|
|
(let ([new-col (fx+ new-col (string-length str))])
|
|
(if (fx= n 0)
|
|
new-col
|
|
(begin
|
|
(carriage-return)
|
|
(line-feed)
|
|
(loop (fx- n 1) (cdr str-lst) new-col))))))))
|
|
|
|
(define (display-rest-of-entry ee entry)
|
|
(let ([row (entry-row entry)]
|
|
[col (entry-col entry)]
|
|
[bot-row (pos-row (entry-bot-line entry))])
|
|
(let loop ([new-row row] [start-col col])
|
|
(let ([new-col (display-rest-of-line ee entry new-row start-col #f)])
|
|
(if (fx= new-row bot-row)
|
|
(values new-row new-col)
|
|
(begin
|
|
(carriage-return)
|
|
(line-feed)
|
|
(ee-display-string (phantom-prompt ee))
|
|
(loop (fx+ new-row 1) 0)))))))
|
|
|
|
(define (display-rest/goto ee entry just-row? clear? to-row to-col)
|
|
; display rest of entry and go directly from there to (to-row, to-col)
|
|
; just-row? => only remainder of current logical row needed by displayed
|
|
; clear? => clear-eos or clear-eol needed
|
|
(let-values ([(cur-row cur-col)
|
|
(if just-row?
|
|
(values
|
|
(entry-row entry)
|
|
(display-rest-of-line ee entry
|
|
(entry-row entry) (entry-col entry) clear?))
|
|
(begin
|
|
(entry-bot-line-set! entry
|
|
(calc-bot-line-displayed entry
|
|
(entry-top-line entry)))
|
|
(when clear? (clear-eos))
|
|
(display-rest-of-entry ee entry)))])
|
|
(unless (and (fx= cur-row (entry-row entry))
|
|
(fx= cur-col (entry-col entry)))
|
|
(entry-row-set! entry cur-row)
|
|
; if the last character written was in the last column of a screen
|
|
; line, move back one so that the cursor is pointing at that character
|
|
; to avoid returning a column value that would wrongly indicate that
|
|
; the cursor is at the start of the next screen line
|
|
(if (and (fx> cur-col 0) (fx= (col->screen-col ee cur-col) 0))
|
|
(begin
|
|
(move-cursor-left 1)
|
|
(entry-col-set! entry (fx- cur-col 1)))
|
|
(entry-col-set! entry cur-col)))
|
|
(goto ee entry (make-pos to-row to-col)))))
|
|
|
|
(module (display-partial-entry)
|
|
(define (display-partial-row ee row str start end)
|
|
; displays physical lines of str from start (inclusive) to end (inclusive)
|
|
; assumes cursor is at column zero of start line; leaves cursor at
|
|
; column zero of end line
|
|
(let ([ls (list-tail (split-string ee str 0) start)])
|
|
(when (fx= start 0)
|
|
(ee-display-string
|
|
(if (fx= row 0)
|
|
(eestate-prompt ee)
|
|
(phantom-prompt ee))))
|
|
(ee-display-string (car ls))
|
|
(carriage-return)
|
|
(do ([i start (fx+ i 1)] [ls (cdr ls) (cdr ls)])
|
|
((fx= i end))
|
|
(line-feed)
|
|
(ee-display-string (car ls))
|
|
(carriage-return))))
|
|
|
|
(define (display-partial-entry ee entry toprow topoff botrow botoff)
|
|
; displays physical screen lines between physical line topoff of
|
|
; toprow (inclusive) and botoff of botrow (inclusive)
|
|
; assumes cursor is at column zero of first physical line to be displayed;
|
|
; leaves cursor at column zero of last line displayed
|
|
(let ([lns (entry-lns entry)])
|
|
(let loop ([r toprow] [start topoff] [lns (list-tail lns toprow)])
|
|
(display-partial-row ee r (ln-str (car lns)) start
|
|
(if (fx= r botrow) botoff (fx- (ln-nsr (car lns)) 1)))
|
|
(unless (fx= r botrow)
|
|
(line-feed)
|
|
(loop (fx+ r 1) 0 (cdr lns)))))))
|
|
|
|
(define (goto-backward ee entry new-row new-col)
|
|
(assert* (fx>= new-row 0)
|
|
(fx>= new-col 0)
|
|
(fx<= new-col (string-length (lns->str (entry-lns entry) new-row))))
|
|
(let* ([lns (entry-lns entry)]
|
|
[row (entry-row entry)]
|
|
[col (entry-col entry)]
|
|
[top-line (entry-top-line entry)]
|
|
[new-str (lns->str lns new-row)]
|
|
[new-len (string-length new-str)]
|
|
[new-row-offset (col->line-offset ee new-col)]
|
|
[new-row-pos (make-pos new-row new-row-offset)]
|
|
[new-bot-line (calc-bot-line-displayed entry new-row-pos)])
|
|
(cond
|
|
; case 1: destination on screen, no scrolling necessary
|
|
; ------------------
|
|
; | (define fact | <--top-line
|
|
; | (lambda (n) | <--new-row
|
|
; | (if (zero? n)| <--point
|
|
; | 1 |
|
|
; | (* n (fac|
|
|
; |t (sub1 n)))))) | <--bot-line
|
|
; | |
|
|
; ------------------
|
|
[(pos>=? new-row-pos (entry-top-line entry))
|
|
(move-cursor-up
|
|
(screen-lines-between ee entry
|
|
new-row new-row-offset
|
|
(entry-row entry) (col->line-offset ee (entry-col entry))))
|
|
(let ([screen-col (col->screen-col ee col)]
|
|
[new-screen-col (col->screen-col ee new-col)])
|
|
(cond
|
|
[(fx> new-screen-col screen-col)
|
|
(move-cursor-right (fx- new-screen-col screen-col))]
|
|
[(fx< new-screen-col screen-col)
|
|
(move-cursor-left (fx- screen-col new-screen-col))]))
|
|
(entry-row-set! entry new-row)
|
|
(entry-col-set! entry new-col)]
|
|
|
|
; case 2: a portion of the old screen overlaps the new screen.
|
|
; we will scroll down and keep the overlap instead of
|
|
; redrawing
|
|
; + = new screen border
|
|
; - = old-screen border
|
|
; ++++++++++++++++++
|
|
; | (define f | <--new-row 0 }extra-top-
|
|
; | (lambda (n) | }lines
|
|
; ------------------
|
|
; | (if (zero? n)| <--top-line (2 . 0)
|
|
; | 1 | <--point (row . col)
|
|
; | (* n | <--new-bot-line (4 . 0)
|
|
; ++++++++++++++++++
|
|
; | (f | <--bot-line (5 . 0)
|
|
; | (1- |
|
|
; ------------------
|
|
; n))))))
|
|
[(pos>? new-bot-line (entry-top-line entry))
|
|
; move cursor to physical column 0 of top screen line
|
|
(move-cursor-up
|
|
(screen-lines-between ee entry
|
|
(pos-row top-line) (pos-col top-line)
|
|
row (col->line-offset ee col)))
|
|
(carriage-return)
|
|
(let ([extra-top-lines
|
|
(screen-lines-between ee entry
|
|
new-row new-row-offset
|
|
(pos-row top-line) (pos-col top-line))])
|
|
; reverse scroll to open up space at the top
|
|
; if we're not actually at the top of the physical display, e.g.,
|
|
; if we only partially displayed the entry after an error or tab-tab,
|
|
; we hope that this goes up a line and clears to end of line. if
|
|
; this ever gives us problems, we'll have avoid getting into this
|
|
; case when less than a screenful of lines has been displayed.
|
|
(scroll-reverse extra-top-lines)
|
|
; display the extra lines
|
|
(let ([r (pos-row top-line)] [off (fx- (pos-col top-line) 1)])
|
|
(if (fx>= off 0)
|
|
(display-partial-entry ee entry new-row new-row-offset r off)
|
|
(display-partial-entry ee entry new-row new-row-offset
|
|
(fx- r 1) (fx- (lns->nsr lns (fx- r 1)) 1))))
|
|
; move cursor back to top
|
|
(move-cursor-up (fx- extra-top-lines 1)))
|
|
(move-cursor-right (col->screen-col ee new-col))
|
|
(entry-col-set! entry new-col)
|
|
(entry-row-set! entry new-row)
|
|
(entry-top-line-set! entry new-row-pos)
|
|
(when (pos<? new-bot-line (entry-bot-line entry))
|
|
(entry-bot-line-set! entry new-bot-line))]
|
|
|
|
; case 3: no overlap between old screen area and new screen
|
|
; area. we will redraw the entire screen
|
|
; + = new screen border
|
|
; - = old-screen border
|
|
; ++++++++++++++++++
|
|
; | (define f | <--new-row 0
|
|
; | (lambda (n) |
|
|
; | (if (zero? n)| <--new-bot-line (4 . 0)
|
|
; ++++++++++++++++++
|
|
; ------------------
|
|
; | 1 | <--top-line (2 . 0)
|
|
; | (* n |
|
|
; | (f | <--bot-line (4 . 1)
|
|
; ------------------
|
|
; (1-
|
|
; n))))))
|
|
[else
|
|
(clear-screen)
|
|
(display-partial-entry ee entry
|
|
new-row new-row-offset
|
|
(pos-row new-bot-line) (pos-col new-bot-line))
|
|
(move-cursor-up
|
|
(screen-lines-between ee entry
|
|
new-row new-row-offset
|
|
(pos-row new-bot-line) (pos-col new-bot-line)))
|
|
(move-cursor-right (col->screen-col ee new-col))
|
|
(entry-col-set! entry new-col)
|
|
(entry-row-set! entry new-row)
|
|
(entry-top-line-set! entry new-row-pos)
|
|
(entry-bot-line-set! entry new-bot-line)])))
|
|
|
|
(define (goto-forward ee entry new-row new-col)
|
|
(assert* (fx< new-row (length (entry-lns entry)))
|
|
(fx>= new-col 0)
|
|
(fx<= new-col (string-length (lns->str (entry-lns entry) new-row))))
|
|
(let* ([lns (entry-lns entry)]
|
|
[row (entry-row entry)]
|
|
[col (entry-col entry)]
|
|
[bot-line (entry-bot-line entry)]
|
|
[new-str (lns->str lns new-row)]
|
|
[new-len (string-length new-str)]
|
|
[new-row-offset (col->line-offset ee new-col)]
|
|
[new-row-pos (make-pos new-row new-row-offset)]
|
|
[new-top-line (calc-top-line-displayed entry new-row-pos)])
|
|
(cond
|
|
; case 1: destination on screen, no scrolling necessary
|
|
; ------------------
|
|
; | (define fact | <--top-line
|
|
; | (lambda (n) | <--point
|
|
; | (if (zero? n)| <--new-row
|
|
; | 1 |
|
|
; | (* n (fac|
|
|
; |t (sub1 n)))))) | <--bot-line
|
|
; | |
|
|
; ------------------
|
|
[(pos<=? new-row-pos bot-line)
|
|
(move-cursor-down
|
|
(screen-lines-between ee entry
|
|
row (col->line-offset ee col)
|
|
new-row new-row-offset))
|
|
(let ([screen-col (col->screen-col ee col)]
|
|
[new-screen-col (col->screen-col ee new-col)])
|
|
(cond
|
|
[(fx> new-screen-col screen-col)
|
|
(move-cursor-right (fx- new-screen-col screen-col))]
|
|
[(fx< new-screen-col screen-col)
|
|
(move-cursor-left (fx- screen-col new-screen-col))]))
|
|
(entry-row-set! entry new-row)
|
|
(entry-col-set! entry new-col)]
|
|
|
|
; case 2: a portion of the old screen overlaps the new screen.
|
|
; we will scroll up and keep the overlap
|
|
;
|
|
; + = new screen border
|
|
; - = old-screen border
|
|
; ------------------
|
|
; | (define f | <--top-line (0 . 0)
|
|
; | (lambda (n) |
|
|
; ++++++++++++++++++
|
|
; | (if (zero? n)| <--new-top-line } scrn-
|
|
; | 1 | <--point (row . col) } draw-
|
|
; | (* n | <--bot-line (4 . 0) } lines
|
|
; ------------------
|
|
; | (f |
|
|
; | (1- | <--new-row 6
|
|
; ++++++++++++++++++
|
|
; n))))))
|
|
[(pos>=? bot-line new-top-line)
|
|
; move cursor to physical col 0 of first line after old bot-line
|
|
(move-cursor-down
|
|
(screen-lines-between ee entry
|
|
row (col->line-offset ee col)
|
|
(pos-row bot-line) (pos-col bot-line)))
|
|
(carriage-return)
|
|
(line-feed)
|
|
(let ([r (pos-row bot-line)] [off (fx+ (pos-col bot-line) 1)])
|
|
(if (fx< off (lns->nsr lns r))
|
|
(display-partial-entry ee entry r off
|
|
new-row new-row-offset)
|
|
(display-partial-entry ee entry (fx+ r 1) 0
|
|
new-row new-row-offset)))
|
|
(move-cursor-right (col->screen-col ee new-col))
|
|
(entry-col-set! entry new-col)
|
|
(entry-row-set! entry new-row)
|
|
(when (pos>? new-top-line (entry-top-line entry))
|
|
(entry-top-line-set! entry new-top-line))
|
|
(entry-bot-line-set! entry new-row-pos)]
|
|
|
|
; case 3: no overlap between old screen area and new screen
|
|
; area. we will redraw the entire screen
|
|
; + = new screen border
|
|
; - = old-screen border
|
|
; ++++++++++++++++++
|
|
; | (define f | <--top-line (0 . 0)
|
|
; | (lambda (n) |
|
|
; | (if (zero? n)| <--bot-line (2 . 0)
|
|
; ++++++++++++++++++
|
|
; ------------------
|
|
; | 1 | <--new-top-line
|
|
; | (* n |
|
|
; | (f | <--new-row, new-row-offset
|
|
; ------------------
|
|
; (1-
|
|
; n))))))
|
|
[else
|
|
(clear-screen)
|
|
(display-partial-entry ee entry
|
|
(pos-row new-top-line) (pos-col new-top-line)
|
|
new-row new-row-offset)
|
|
(move-cursor-right (col->screen-col ee new-col))
|
|
(entry-col-set! entry new-col)
|
|
(entry-row-set! entry new-row)
|
|
(entry-top-line-set! entry new-top-line)
|
|
(entry-bot-line-set! entry new-row-pos)])))
|
|
|
|
(define (goto ee entry p)
|
|
(let ([new-row (pos-row p)] [new-col (pos-col p)])
|
|
(assert* (fx< new-row (length (entry-lns entry)))
|
|
(fx<= new-col (string-length (lns->str (entry-lns entry) new-row))))
|
|
(if (or (fx< new-row (entry-row entry))
|
|
(and (fx= new-row (entry-row entry))
|
|
(fx< new-col (entry-col entry))))
|
|
(goto-backward ee entry new-row new-col)
|
|
(goto-forward ee entry new-row new-col))))
|
|
|
|
(defopt (move-up ee entry [n 1])
|
|
(assert* (fx>= (fx- (entry-row entry) n) 0))
|
|
(let ([new-row (fx- (entry-row entry) n)])
|
|
(goto-backward ee entry new-row
|
|
(fxmin (entry-col entry)
|
|
(string-length (lns->str (entry-lns entry) new-row))))))
|
|
|
|
(defopt (move-down ee entry [n 1])
|
|
(assert* (fx< (fx+ (entry-row entry) n) (length (entry-lns entry))))
|
|
(let ([new-row (fx+ (entry-row entry) n)])
|
|
(goto-forward ee entry new-row
|
|
(fxmin (entry-col entry)
|
|
(string-length (lns->str (entry-lns entry) new-row))))))
|
|
|
|
(defopt (move-left ee entry [n 1])
|
|
(let ([new-col (fx- (entry-col entry) n)])
|
|
(assert* (fx>= new-col 0))
|
|
(goto-backward ee entry (entry-row entry) new-col)))
|
|
|
|
(defopt (move-right ee entry [n 1])
|
|
(let ([new-col (fx+ (entry-col entry) n)])
|
|
(assert* (fx<= new-col (string-length (lns->str (entry-lns entry) (entry-row entry)))))
|
|
(goto-forward ee entry (entry-row entry) new-col)))
|
|
|
|
(define (page-down ee entry)
|
|
(let* ([last-row (fx- (length (entry-lns entry)) 1)]
|
|
[row (entry-row entry)]
|
|
[col (entry-col entry)]
|
|
[point-line-offset (col->line-offset ee col)]
|
|
[top-line (entry-top-line entry)]
|
|
[bot-line (entry-bot-line entry)]
|
|
[n (screen-lines-between ee entry
|
|
(pos-row top-line) (pos-col top-line)
|
|
(pos-row bot-line) (pos-col bot-line))])
|
|
(let f ([r (fxmin (fx+ row n) last-row)])
|
|
(if (fx= r row)
|
|
(unless (fx= r last-row)
|
|
(goto-forward ee entry (fx+ r 1)
|
|
(fxmin col (string-length (lns->str (entry-lns entry) (fx+ r 1))))))
|
|
(let ([c (fxmin col (string-length (lns->str (entry-lns entry) r)))])
|
|
(if (<= (screen-lines-between ee entry
|
|
row point-line-offset
|
|
r (col->line-offset ee c))
|
|
n)
|
|
(goto-forward ee entry r c)
|
|
(f (fx- r 1))))))))
|
|
|
|
(define (page-up ee entry)
|
|
(let* ([row (entry-row entry)]
|
|
[col (entry-col entry)]
|
|
[point-line-offset (col->line-offset ee col)]
|
|
[top-line (entry-top-line entry)]
|
|
[bot-line (entry-bot-line entry)]
|
|
[n (screen-lines-between ee entry
|
|
(pos-row top-line) (pos-col top-line)
|
|
(pos-row bot-line) (pos-col bot-line))])
|
|
(let f ([r (max (fx- row n) 0)])
|
|
(if (fx= r row)
|
|
(unless (fx= r 0)
|
|
(goto-backward ee entry (fx- r 1)
|
|
(fxmin col (string-length (lns->str (entry-lns entry) (fx- r 1))))))
|
|
(let ([c (fxmin col (string-length (lns->str (entry-lns entry) r)))])
|
|
(if (<= (screen-lines-between ee entry
|
|
r (col->line-offset ee c)
|
|
row point-line-offset)
|
|
n)
|
|
(goto-backward ee entry r c)
|
|
(f (fx+ r 1))))))))
|
|
|
|
(define (move-eol ee entry)
|
|
(move-right ee entry
|
|
(fx- (string-length (lns->str (entry-lns entry) (entry-row entry)))
|
|
(entry-col entry))))
|
|
|
|
(define (move-bol ee entry)
|
|
(move-left ee entry (entry-col entry)))
|
|
|
|
(define (move-eoe ee entry)
|
|
(let ([lns (entry-lns entry)])
|
|
(let ([r (fx- (length lns) 1)])
|
|
(goto-forward ee entry r (string-length (lns->str lns r))))))
|
|
|
|
(define (move-to-col-pos ee entry new-col)
|
|
(let ([col (entry-col entry)])
|
|
(if (fx< new-col col)
|
|
(move-left ee entry (fx- col new-col))
|
|
(move-right ee entry (fx- new-col col)))))
|
|
|
|
(define (adjust-mark/delete ee entry r1 c1 r2 c2)
|
|
(let ([mark (entry-mark entry)])
|
|
(when mark
|
|
(let ([mrow (pos-row mark)] [mcol (pos-col mark)])
|
|
(unless (or (fx< mrow r1) (and (fx= mrow r1) (fx< mcol c1)))
|
|
(entry-mark-set! entry
|
|
(and (not (or (fx< mrow r2) (and (fx= mrow r2) (fx< mcol c2))))
|
|
(make-pos
|
|
(fx- mrow (fx- r2 r1))
|
|
(if (fx= mrow r2) (fx+ c1 (fx- mcol c2)) mcol)))))))))
|
|
|
|
(define (adjust-mark/insert ee entry r1 c1 r2 c2)
|
|
(let ([mark (entry-mark entry)])
|
|
(when mark
|
|
(let ([mrow (pos-row mark)] [mcol (pos-col mark)])
|
|
(unless (or (fx< mrow r1) (and (fx= mrow r1) (fx< mcol c1)))
|
|
(entry-mark-set! entry
|
|
(make-pos
|
|
(fx+ mrow (fx- r2 r1))
|
|
(if (fx= mrow r1) (fx+ c2 (fx- mcol c1)) mcol))))))))
|
|
|
|
(define (delete-forward ee entry r2 c2)
|
|
; deletes from point, aka r1, c1 (inclusive) to r2, c2 (exclusive)
|
|
; and returns the deleted content as a list of strings
|
|
(let ([r1 (entry-row entry)] [c1 (entry-col entry)])
|
|
(assert* (or (fx< r1 r2) (and (fx= r1 r2) (fx<= c1 c2))))
|
|
(adjust-mark/delete ee entry r1 c1 r2 c2)
|
|
(if (fx= r1 r2)
|
|
(let* ([ln (list-ref (entry-lns entry) r1)]
|
|
[s (ln-str ln)]
|
|
[old-nsr (ln-nsr ln)])
|
|
(ln-str-set! ee ln
|
|
(string-append
|
|
(substring s 0 c1)
|
|
(substring s c2 (string-length s))))
|
|
(display-rest/goto ee entry (fx= (ln-nsr ln) old-nsr) #t r1 c1)
|
|
(list (substring s c1 c2)))
|
|
(let* ([lns (entry-lns entry)]
|
|
[ls1 (list-tail lns r1)]
|
|
[ls2 (list-tail ls1 (fx- r2 r1))]
|
|
[s1 (ln-str (car ls1))]
|
|
[s2 (ln-str (car ls2))])
|
|
(ln-str-set! ee (car ls1)
|
|
(string-append
|
|
(substring s1 0 c1)
|
|
(substring s2 c2 (string-length s2))))
|
|
(let ([deleted
|
|
(cons (substring s1 c1 (string-length s1))
|
|
(let f ([ls (cdr ls1)])
|
|
(if (eq? ls ls2)
|
|
(list (substring s2 0 c2))
|
|
(cons (ln-str (car ls)) (f (cdr ls))))))])
|
|
(set-cdr! ls1 (cdr ls2))
|
|
(display-rest/goto ee entry #f #t r1 c1)
|
|
deleted)))))
|
|
|
|
(define (delete-char ee entry)
|
|
(assert* (not (end-of-line? ee entry)))
|
|
(let ([row (entry-row entry)] [col (entry-col entry)])
|
|
(delete-forward ee entry row (fx+ col 1))))
|
|
|
|
(define (delete-to-eol ee entry)
|
|
(let ([row (entry-row entry)])
|
|
(delete-forward ee entry row
|
|
(string-length (lns->str (entry-lns entry) row)))))
|
|
|
|
(define (join-rows ee entry)
|
|
(assert* (end-of-line? ee entry) (not (last-line? ee entry)))
|
|
(delete-forward ee entry (fx+ (entry-row entry) 1) 0))
|
|
|
|
(define (insert-string-before ee entry new-str)
|
|
(let* ([row (entry-row entry)]
|
|
[col (entry-col entry)]
|
|
[lns (entry-lns entry)]
|
|
[ln (list-ref lns row)]
|
|
[str (ln-str ln)]
|
|
[str-len (string-length str)]
|
|
[new-col (fx+ col (string-length new-str))]
|
|
[nsr (ln-nsr ln)]
|
|
[eoe? (end-of-entry? ee entry)])
|
|
(ln-str-set! ee ln
|
|
(string-append
|
|
(substring str 0 col)
|
|
new-str
|
|
(substring str col (string-length str))))
|
|
(let ([just-row? (fx= (ln-nsr ln) nsr)])
|
|
(display-rest/goto ee entry just-row?
|
|
; avoid clear-eol/eos if insertion takes place at end of entry or
|
|
; if rewriting just the current row
|
|
(and (not eoe?) (not just-row?))
|
|
row new-col))
|
|
(adjust-mark/insert ee entry row col row new-col)))
|
|
|
|
(define (add-char ee entry c)
|
|
; add character after point, then move point forward one character
|
|
(assert* (char? c))
|
|
(insert-string-before ee entry (string c)))
|
|
|
|
(define (insert-strings-before ee entry strs)
|
|
(unless (null? strs)
|
|
(if (fx= (length strs) 1)
|
|
(insert-string-before ee entry (car strs))
|
|
(let* ([row (entry-row entry)]
|
|
[col (entry-col entry)]
|
|
[lns (entry-lns entry)]
|
|
[ls (list-tail lns row)]
|
|
[ln (car ls)]
|
|
[point-str (ln-str ln)]
|
|
[eoe? (end-of-entry? ee entry)])
|
|
(ln-str-set! ee ln
|
|
(string-append (substring point-str 0 col) (car strs)))
|
|
(set-cdr! ls
|
|
(let f ([str (cadr strs)] [strs (cddr strs)])
|
|
(if (null? strs)
|
|
(cons (make-ln ee
|
|
(string-append str
|
|
(substring point-str col
|
|
(string-length point-str))))
|
|
(cdr ls))
|
|
(cons (make-ln ee str)
|
|
(f (car strs) (cdr strs))))))
|
|
(let* ([n (fx- (length strs) 1)]
|
|
[new-row (fx+ row n)]
|
|
[new-col (string-length (list-ref strs n))])
|
|
(display-rest/goto ee entry #f (not eoe?) new-row new-col)
|
|
(adjust-mark/insert ee entry row col new-row new-col))))))
|
|
|
|
(define (first-line? ee entry) (fxzero? (entry-row entry)))
|
|
|
|
(define (last-line? ee entry)
|
|
(fx= (entry-row entry) (fx1- (length (entry-lns entry)))))
|
|
|
|
(define (last-line-displayed? ee entry)
|
|
(pos=? (make-pos (entry-row entry) (col->line-offset ee (entry-col entry)))
|
|
(entry-bot-line entry)))
|
|
|
|
(define (visible? ee entry row col)
|
|
(let ([line (make-pos row (col->line-offset ee col))])
|
|
(and (pos<=? (entry-top-line entry) line)
|
|
(pos<=? line (entry-bot-line entry)))))
|
|
|
|
(define (end-of-line? ee entry)
|
|
(fx= (entry-col entry)
|
|
(string-length (lns->str (entry-lns entry) (entry-row entry)))))
|
|
|
|
(define (end-of-entry? ee entry)
|
|
(and (fx= (entry-row entry) (fx- (length (entry-lns entry)) 1))
|
|
(end-of-line? ee entry)))
|
|
|
|
(define (beginning-of-line? ee entry) (fx= (entry-col entry) 0))
|
|
|
|
; returns #t iff only spaces and newlines are left after point
|
|
(define (only-whitespace-left? ee entry)
|
|
(let f ([ls (list-tail (entry-lns entry) (entry-row entry))]
|
|
[col (entry-col entry)])
|
|
(or (null? ls)
|
|
(let* ([s (ln-str (car ls))] [n (string-length s)])
|
|
(let g ([col col])
|
|
(if (fx= col n)
|
|
(f (cdr ls) 0)
|
|
(and (char=? (string-ref s col) #\space)
|
|
(g (fx+ col 1)))))))))
|
|
|
|
(define (handle-winch ee entry)
|
|
(screen-resize!)
|
|
(unless (and (fx= (screen-rows) (entry-screen-rows entry))
|
|
(fx= (screen-cols) (entry-screen-cols entry)))
|
|
(clear-entry ee entry)
|
|
(redisplay ee entry)))
|
|
|
|
(module (redisplay)
|
|
(define (set-screen-size! ee entry)
|
|
(screen-resize!)
|
|
(unless (and (fx= (entry-screen-cols entry) (screen-cols))
|
|
(fx= (entry-screen-rows entry) (screen-rows)))
|
|
(for-each
|
|
(lambda (ln) (ln-nsr-set! ln (str->nsr ee (ln-str ln))))
|
|
(entry-lns entry))
|
|
(entry-screen-cols-set! entry (screen-cols))
|
|
(entry-screen-rows-set! entry (screen-rows))))
|
|
|
|
(defopt (redisplay ee entry [nrows #f])
|
|
(set-screen-size! ee entry)
|
|
(let* ([nrows (or nrows (screen-rows))] ; want new screen-rows
|
|
[row (entry-row entry)]
|
|
[col (entry-col entry)]
|
|
[point-line (make-pos row (col->line-offset ee col))])
|
|
(entry-bot-line-set! entry
|
|
(calc-bot-line-displayed entry (entry-top-line entry) nrows))
|
|
(when (pos>? point-line (entry-bot-line entry))
|
|
(entry-bot-line-set! entry point-line))
|
|
(entry-top-line-set! entry
|
|
(calc-top-line-displayed entry (entry-bot-line entry) nrows))
|
|
(when (pos<? point-line (entry-top-line entry))
|
|
(entry-top-line-set! entry point-line)
|
|
(entry-bot-line-set! entry
|
|
(calc-bot-line-displayed entry (entry-top-line entry) nrows)))
|
|
(let ([top-line (entry-top-line entry)] [bot-line (entry-bot-line entry)])
|
|
(display-partial-entry ee entry
|
|
(pos-row top-line) (pos-col top-line)
|
|
(pos-row bot-line) (pos-col bot-line))
|
|
(move-cursor-up
|
|
(screen-lines-between ee entry
|
|
(pos-row point-line) (pos-col point-line)
|
|
(pos-row bot-line) (pos-col bot-line)))
|
|
(move-cursor-right (col->screen-col ee col))))))
|
|
|
|
(define (flash ee entry mpos)
|
|
(let ([point-pos (entry-point entry)])
|
|
(cond
|
|
[(visible? ee entry (pos-row mpos) (pos-col mpos))
|
|
(goto ee entry mpos)
|
|
(ee-flush)
|
|
(wait (ee-paren-flash-delay))
|
|
(goto ee entry point-pos)]
|
|
[(pos<? mpos point-pos)
|
|
(let ([nlines
|
|
(screen-lines-between ee entry
|
|
(pos-row (entry-top-line entry))
|
|
(pos-col (entry-top-line entry))
|
|
(pos-row point-pos)
|
|
(col->line-offset ee (pos-col point-pos)))]
|
|
[ncols (col->screen-col ee (pos-col point-pos))])
|
|
(move-cursor-left ncols)
|
|
(move-cursor-up nlines)
|
|
(ee-flush)
|
|
(wait (ee-paren-flash-delay))
|
|
(move-cursor-down nlines)
|
|
(move-cursor-right ncols))]
|
|
[else
|
|
(let ([nlines
|
|
(screen-lines-between ee entry
|
|
(pos-row point-pos)
|
|
(col->line-offset ee (pos-col point-pos))
|
|
(pos-row (entry-bot-line entry))
|
|
(pos-col (entry-top-line entry)))]
|
|
[ncols (col->screen-col ee (pos-col point-pos))])
|
|
(move-cursor-left ncols)
|
|
(move-cursor-down nlines)
|
|
(ee-flush)
|
|
(wait (ee-paren-flash-delay))
|
|
(move-cursor-up nlines)
|
|
(move-cursor-right ncols))])))
|
|
|
|
(define (correct&flash-matching-delimiter ee entry)
|
|
(define (expected left) (if (eqv? left lbchar) rbchar rpchar))
|
|
(move-left ee entry 1) ; move over delim
|
|
(let ([lns (entry-lns entry)])
|
|
(let* ([row (entry-row entry)]
|
|
[col (entry-col entry)]
|
|
[str (lns->str lns row)]
|
|
[c (string-ref str col)])
|
|
(if (or (char=? c lpchar) (char=? c lbchar))
|
|
; don't correct close delimiter when inserting open delimiter
|
|
; since doing so often leads to surprising results
|
|
(when (ee-flash-parens)
|
|
(cond
|
|
[(find-matching-delim-forward ee entry row col #f) =>
|
|
(lambda (mpos) (flash ee entry mpos))]))
|
|
(cond
|
|
[(find-matching-delim-backward ee entry row col
|
|
(ee-auto-paren-balance)) =>
|
|
(lambda (mpos)
|
|
(let ([cexp (expected
|
|
(string-ref
|
|
(lns->str lns (pos-row mpos))
|
|
(pos-col mpos)))])
|
|
(unless (eqv? c cexp)
|
|
(string-set! str col cexp)
|
|
(ee-write-char cexp)
|
|
(move-cursor-left 1)))
|
|
(when (ee-flash-parens) (flash ee entry mpos)))]))))
|
|
(move-right ee entry 1))
|
|
|
|
(define (find-matching-delimiter ee entry)
|
|
(let ([row (entry-row entry)]
|
|
[col (entry-col entry)]
|
|
[str (lns->str (entry-lns entry) (entry-row entry))])
|
|
(and (fx< col (string-length str))
|
|
(let ([c (string-ref str col)])
|
|
(if (or (char=? c lpchar) (char=? c lbchar))
|
|
(find-matching-delim-forward ee entry row col #f)
|
|
(and (or (char=? c rpchar) (char=? c rbchar))
|
|
(find-matching-delim-backward ee entry row col #f)))))))
|
|
|
|
(define (find-matching-delim-backward ee entry row col lax?)
|
|
(let ([lns (entry-lns entry)])
|
|
; 1. create string representing current entry through row, col
|
|
; 2. search forward, stacking left/right delimiters and their indices
|
|
; 3. if matching delimiter found, convert string index to pos
|
|
(let* ([s (let ([op (open-output-string)])
|
|
(let loop ([i 0] [sep ""])
|
|
(let ([str (lns->str lns i)])
|
|
(if (= i row)
|
|
(fprintf op "~a~a" sep (substring str 0 (fx+ col 1)))
|
|
(begin
|
|
(fprintf op "~a~a" sep str)
|
|
(loop (fx+ i 1) "\n")))))
|
|
(get-output-string op))]
|
|
[ip (open-input-string s)])
|
|
(let loop ([stack '()])
|
|
(on-error (loop '())
|
|
(let-values ([(type value start end) (read-token ip)])
|
|
(case type
|
|
[(atomic box dot insert mark quote) (loop stack)]
|
|
[(lbrack record-brack)
|
|
(loop (cons (cons 'rbrack end) stack))]
|
|
[(lparen vfxnparen vfxparen vnparen vparen vu8nparen vu8paren)
|
|
(loop (cons (cons 'rparen end) stack))]
|
|
[(rbrack rparen)
|
|
(if (= end (string-length s))
|
|
(and (not (null? stack))
|
|
(or lax? (eq? (caar stack) type))
|
|
(index->pos s (fx- (cdar stack) 1) 0 0))
|
|
(if (and (not (null? stack)) (eq? (caar stack) type))
|
|
(loop (cdr stack))
|
|
(loop '())))]
|
|
[(eof fasl) #f]
|
|
[else
|
|
(warningf 'expeditor "unexpected token type ~s from read-token" type)
|
|
#f])))))))
|
|
|
|
(define (find-matching-delim-forward ee entry row col lax?)
|
|
(let ([lns (entry-lns entry)])
|
|
; should be sitting on left paren or bracket
|
|
(assert* (or (char=? (lns->char lns row col) lpchar)
|
|
(char=? (lns->char lns row col) lbchar)))
|
|
; 1. create string representing current entry starting at col, row
|
|
; 2. search forward until matching delimiter, eof, or error
|
|
; 3. if matching delimiter found, convert string index to pos
|
|
(let* ([s (let ([op (open-output-string)] [l-lns (length lns)])
|
|
(let ([s (lns->str lns row)])
|
|
(display (substring s col (string-length s)) op))
|
|
(let loop ([i (fx+ row 1)])
|
|
(unless (fx= i l-lns)
|
|
(fprintf op "\n~a" (lns->str lns i))
|
|
(loop (fx+ i 1))))
|
|
(get-output-string op))]
|
|
[ip (open-input-string s)])
|
|
(on-error #f
|
|
(let loop ([stack '()])
|
|
(let-values ([(type value start end) (read-token ip)])
|
|
(case type
|
|
[(atomic box dot insert mark quote) (loop stack)]
|
|
[(lbrack record-brack)
|
|
(loop (cons 'rbrack stack))]
|
|
[(lparen vfxnparen vfxparen vnparen vparen vu8nparen vu8paren)
|
|
(loop (cons 'rparen stack))]
|
|
[(rbrack rparen)
|
|
(if (fx= (length stack) 1)
|
|
(and (or lax? (eq? (car stack) type))
|
|
(index->pos s start row col))
|
|
(and (eq? (car stack) type) (loop (cdr stack))))]
|
|
[(eof fasl) #f]
|
|
[else
|
|
(warningf 'expeditor "unexpected token type ~s from read-token" type)
|
|
#f])))))))
|
|
|
|
(define (find-next-sexp-backward ee entry row col)
|
|
(let* ([lns (entry-lns entry)]
|
|
[s (let ([op (open-output-string)])
|
|
(let loop ([i 0] [sep ""])
|
|
(let ([str (lns->str lns i)])
|
|
(if (= i row)
|
|
(fprintf op "~a~a" sep (substring str 0 col))
|
|
(begin
|
|
(fprintf op "~a~a" sep str)
|
|
(loop (fx+ i 1) "\n")))))
|
|
(get-output-string op))]
|
|
[ip (open-input-string s)])
|
|
(on-error #f
|
|
(let loop ([stack '()] [last-start 0])
|
|
(let-values ([(type value start end) (read-token ip)])
|
|
(case type
|
|
[(atomic dot insert mark)
|
|
(if (and (not (null? stack)) (eq? (caar stack) 'qubx))
|
|
(loop (cdr stack) (cdar stack))
|
|
(loop stack start))]
|
|
[(box quote)
|
|
(if (and (not (null? stack)) (eq? (caar stack) 'qubx))
|
|
(loop stack #f)
|
|
(loop (cons (cons 'qubx start) stack) #f))]
|
|
[(eof) (and last-start (index->pos s last-start 0 0))]
|
|
[(lbrack record-brack)
|
|
(if (and (not (null? stack)) (eq? (caar stack) 'qubx))
|
|
(loop (cons (cons 'rbrack (cdar stack)) (cdr stack)) #f)
|
|
(loop (cons (cons 'rbrack start) stack) #f))]
|
|
[(lparen vfxnparen vfxparen vnparen vparen vu8nparen vu8paren)
|
|
(if (and (not (null? stack)) (eq? (caar stack) 'qubx))
|
|
(loop (cons (cons 'rparen (cdar stack)) (cdr stack)) #f)
|
|
(loop (cons (cons 'rparen start) stack) #f))]
|
|
[(rbrack rparen)
|
|
(if (and (not (null? stack)) (eq? (caar stack) type))
|
|
(loop (cdr stack) (cdar stack))
|
|
(loop '() #f))]
|
|
[else
|
|
(warningf 'expeditor "unexpected token type ~s from read-token" type)
|
|
#f]))))))
|
|
|
|
(define (find-next-sexp-forward ee entry row col ignore-whitespace?)
|
|
; ordinarily stops at first s-expression if it follows whitespace (or
|
|
; comments), but always moves to second if ignore-whitespace? is true
|
|
(let* ([lns (entry-lns entry)]
|
|
[s (let ([op (open-output-string)] [l-lns (length lns)])
|
|
(let ([s (lns->str lns row)])
|
|
(display (substring s col (string-length s)) op))
|
|
(let loop ([i (fx+ row 1)])
|
|
(unless (fx= i l-lns)
|
|
(fprintf op "\n~a" (lns->str lns i))
|
|
(loop (fx+ i 1))))
|
|
(get-output-string op))]
|
|
[ip (open-input-string s)])
|
|
(define (skip start)
|
|
(index->pos s
|
|
(on-error start
|
|
(let-values ([(type value start end) (read-token ip)])
|
|
start))
|
|
row col))
|
|
(on-error #f
|
|
(let loop ([stack '()] [first? #t] [ignore? #f])
|
|
(let-values ([(type value start end) (read-token ip)])
|
|
(if (and first? (not ignore-whitespace?) (fx> start 0))
|
|
(and (not ignore?) (index->pos s start row col))
|
|
(case type
|
|
[(atomic dot insert mark)
|
|
(if (null? stack)
|
|
(and (not ignore?) (skip start))
|
|
(loop stack #f ignore?))]
|
|
[(box) (loop stack #f ignore?)]
|
|
[(quote)
|
|
(when (and ignore-whitespace?
|
|
(eq? value 'datum-comment)
|
|
(null? stack))
|
|
(loop '() #f #t))
|
|
(loop stack #f ignore?)]
|
|
[(eof fasl) #f]
|
|
[(lbrack record-brack) (loop (cons 'rbrack stack) #f ignore?)]
|
|
[(lparen vfxnparen vfxparen vnparen vparen vu8nparen vu8paren)
|
|
(loop (cons 'rparen stack) #f ignore?)]
|
|
[(rbrack rparen)
|
|
(and (not (null? stack))
|
|
(eq? (car stack) type)
|
|
(let ([stack (cdr stack)])
|
|
(if (null? stack)
|
|
(and (not ignore?) (skip start))
|
|
(loop stack #f ignore?))))]
|
|
[else
|
|
(warningf 'expeditor "unexpected token type ~s from read-token" type)
|
|
#f])))))))
|
|
|
|
(module (find-next-word find-previous-word)
|
|
(define separator?
|
|
(lambda (c)
|
|
(memq c '(#\space #\; #\( #\) #\[ #\] #\" #\' #\`))))
|
|
|
|
(define (find-next-word ee entry row col)
|
|
; always returns a position
|
|
(let ([lns (entry-lns entry)])
|
|
; skip past separators
|
|
(let loop ([row row] [col col])
|
|
(cond
|
|
[(fx= col (string-length (lns->str lns row)))
|
|
(if (fx= row (fx1- (length lns)))
|
|
(make-pos row col)
|
|
(loop (fx1+ row) 0))]
|
|
[(separator? (lns->char lns row col))
|
|
(loop row (fx1+ col))]
|
|
; now we are past initial separators, find next separator
|
|
[else
|
|
(let loop ([col col])
|
|
(cond
|
|
[(or (fx= col (string-length (lns->str lns row)))
|
|
(separator? (lns->char lns row col)))
|
|
(make-pos row col)]
|
|
[else (loop (fx1+ col))]))]))))
|
|
|
|
(define (find-previous-word ee entry row col)
|
|
; always returns a position
|
|
(let ([lns (entry-lns entry)])
|
|
; skip past separators space (starts at char left of current)
|
|
(let loop ([row row] [col col])
|
|
(cond
|
|
[(fx= col 0)
|
|
(if (fx= row 0)
|
|
(make-pos row col)
|
|
(loop
|
|
(fx1- row)
|
|
(string-length (lns->str lns (fx1- row)))))]
|
|
[(separator? (lns->char lns row (fx1- col)))
|
|
(loop row (fx1- col))]
|
|
; now we are past initial separators, find next separator
|
|
[else
|
|
(let loop ([col col])
|
|
(cond
|
|
[(or (fx= col 0)
|
|
(separator? (lns->char lns row (fx1- col))))
|
|
(make-pos row col)]
|
|
[else (loop (fx1- col))]))])))))
|
|
|
|
(module (indent indent-all)
|
|
(define (calc-indent ee entry row)
|
|
(define (find-unmatched-left-delim row)
|
|
(let* ([ln (list-ref (entry-lns entry) row)]
|
|
[s (ln-str ln)])
|
|
(ln-str-set! ee ln (string rpchar))
|
|
(let ([pos (find-matching-delim-backward ee entry row 0 #t)])
|
|
(ln-str-set! ee ln s)
|
|
pos)))
|
|
(let ([lns (entry-lns entry)])
|
|
(cond
|
|
[(find-unmatched-left-delim row) =>
|
|
(lambda (mpos)
|
|
(let ([mrow (pos-row mpos)] [mcol (pos-col mpos)])
|
|
(or
|
|
; if some intervening line has same unmatched left
|
|
; delimiter, use its indentation
|
|
(let f ([xrow (fx- row 1)])
|
|
(and (not (fx= xrow mrow))
|
|
(cond
|
|
[(find-unmatched-left-delim xrow) =>
|
|
(lambda (xmpos)
|
|
(if (pos=? xmpos mpos)
|
|
(current-indent lns xrow)
|
|
(f (fx- xrow 1))))]
|
|
[else (f (fx- xrow 1))])))
|
|
; otherwise, if left paren is followed by a symbol,
|
|
; indent under second item or use standard indent if
|
|
; second item is too far out or not present
|
|
(let ([ip (open-input-string
|
|
(let ([s (lns->str lns mrow)])
|
|
(substring s mcol (string-length s))))])
|
|
(on-error #f
|
|
(and (char=? (read-char ip) lpchar)
|
|
(let-values ([(t1 v1 s1 e1) (read-token ip)])
|
|
(and (and (eq? t1 'atomic) (symbol? v1))
|
|
(let-values ([(t2 v2 s2 e2) (read-token ip)])
|
|
(if (and (not (eq? t2 'eof))
|
|
(fx< s2 6)
|
|
; use standard indent for let and rec
|
|
(not (memq v1 '(let rec))))
|
|
(fx+ mcol s2)
|
|
(fx+ mcol (ee-standard-indent)))))))))
|
|
; otherwise, indent one space in. this handles, among
|
|
; other things, bracketed let bindings and cond clauses.
|
|
(fx+ mcol 1))))]
|
|
[else 0])))
|
|
|
|
(define current-indent
|
|
(lambda (lns row)
|
|
(let* ([s (lns->str lns row)]
|
|
[n (string-length s)])
|
|
(let f ([i 0])
|
|
(if (and (fx< i n) (char=? (string-ref s i) #\space))
|
|
(f (fx+ i 1))
|
|
i)))))
|
|
|
|
(define (indent-row! ee entry row n)
|
|
(cond
|
|
[(fx< n 0)
|
|
(adjust-mark/delete ee entry row 0 row (fx- n))
|
|
(let ([lns (entry-lns entry)])
|
|
(lns->str! ee lns row
|
|
(let ([s (lns->str lns row)])
|
|
(substring s (fx- n) (string-length s)))))]
|
|
[(fx> n 0)
|
|
(adjust-mark/insert ee entry row 0 row n)
|
|
(let ([lns (entry-lns entry)])
|
|
(lns->str! ee lns row
|
|
(string-append
|
|
(make-string n #\space)
|
|
(lns->str lns row))))]))
|
|
|
|
(define (indent ee entry)
|
|
(let* ([row (entry-row entry)]
|
|
[lns (entry-lns entry)]
|
|
[n (fx- (calc-indent ee entry row) (current-indent lns row))])
|
|
(unless (fx= n 0)
|
|
(let* ([ln (list-ref lns row)]
|
|
[nsr (ln-nsr ln)]
|
|
[eoe? (end-of-entry? ee entry)])
|
|
(indent-row! ee entry row n)
|
|
(move-bol ee entry)
|
|
(let ([just-row? (fx= (ln-nsr ln) nsr)])
|
|
(display-rest/goto ee entry just-row?
|
|
; avoid clear-eol/eos if inserting and either at end of entry or
|
|
; rewriting just the current row
|
|
(or (fx< n 0) (and (not eoe?) (not just-row?)))
|
|
row (fxmax (fx+ (entry-col entry) n) 0)))))))
|
|
|
|
(define (indent-all ee entry)
|
|
(let* ([lns (entry-lns entry)]
|
|
[row (entry-row entry)]
|
|
[col (entry-col entry)]
|
|
[top-line (entry-top-line entry)]
|
|
[point-ln (list-ref lns row)]
|
|
[point-strlen (string-length (ln-str point-ln))]
|
|
[lines-to-top ; compute before we muck with indentation
|
|
(screen-lines-between ee entry
|
|
(pos-row top-line) (pos-col top-line)
|
|
row (col->line-offset ee col))])
|
|
(let loop ([ls lns] [i 0] [firstmod (length lns)] [lastmod -1])
|
|
(if (null? ls)
|
|
(unless (and (fx< lastmod (pos-row top-line))
|
|
(fx> firstmod (pos-row (entry-bot-line entry))))
|
|
; move to first physical column of first displayed line
|
|
(move-cursor-up lines-to-top)
|
|
(carriage-return)
|
|
(clear-eos)
|
|
(entry-col-set! entry
|
|
(fxmax 0
|
|
(fx+ col
|
|
(fx- (string-length (ln-str point-ln))
|
|
point-strlen))))
|
|
(redisplay ee entry))
|
|
(let ([n (fx- (calc-indent ee entry i) (current-indent lns i))])
|
|
(if (fx= n 0)
|
|
(loop (cdr ls) (fx+ i 1) firstmod lastmod)
|
|
(begin
|
|
(indent-row! ee entry i n)
|
|
(loop (cdr ls) (fx+ i 1)
|
|
(fxmin i firstmod)
|
|
(fxmax i lastmod)))))))))
|
|
)
|
|
|
|
(define (id-completions ee entry)
|
|
(define (idstring<? prefix)
|
|
(let ([common (ee-common-identifiers)]
|
|
[scheme-syms (environment-symbols (scheme-environment))])
|
|
(lambda (s1 s2)
|
|
(let ([x1 (string->symbol (string-append prefix s1))]
|
|
[x2 (string->symbol (string-append prefix s2))])
|
|
; prefer common
|
|
(let ([m1 (memq x1 common)] [m2 (memq x2 common)])
|
|
(if m1
|
|
(or (not m2) (< (length m2) (length m1)))
|
|
(and (not m2)
|
|
; prefer user-defined
|
|
(let ([u1 (not (memq x1 scheme-syms))]
|
|
[u2 (not (memq x2 scheme-syms))])
|
|
(if u1
|
|
(or (not u2) (string<? s1 s2))
|
|
(and (not u2) (string<? s1 s2)))))))))))
|
|
(define (completion str1 str2)
|
|
(let ([n1 (string-length str1)] [n2 (string-length str2)])
|
|
(and (fx>= n2 n1)
|
|
(string=? (substring str2 0 n1) str1)
|
|
(substring str2 n1 n2))))
|
|
(define (fn-completions prefix)
|
|
(values prefix
|
|
(sort string<?
|
|
(fold-left
|
|
(let ([last (path-last prefix)])
|
|
(lambda (suffix* s)
|
|
(cond
|
|
[(completion last s) =>
|
|
(lambda (suffix)
|
|
(cons (if (file-directory? (string-append prefix suffix))
|
|
(string-append suffix (string (directory-separator)))
|
|
suffix)
|
|
suffix*))]
|
|
[else suffix*])))
|
|
'()
|
|
(on-error '()
|
|
(directory-list
|
|
(let ([dir (path-parent prefix)])
|
|
(if (string=? dir "") "." dir))))))))
|
|
(let loop ([c 0])
|
|
(if (fx>= c (entry-col entry))
|
|
(values #f '())
|
|
(let ([s (let ([s (lns->str (entry-lns entry) (entry-row entry))])
|
|
(substring s c (string-length s)))])
|
|
((on-error
|
|
(lambda ()
|
|
(if (and (fx> (string-length s) 0) (char=? (string-ref s 0) #\"))
|
|
(fn-completions (substring s 1 (string-length s)))
|
|
(loop (fx+ c 1))))
|
|
(let-values ([(type value start end) (read-token (open-input-string s))])
|
|
(lambda ()
|
|
(cond
|
|
[(and (fx= (fx+ c end) (entry-col entry))
|
|
(eq? type 'atomic)
|
|
(symbol? value))
|
|
(let ([prefix (symbol->string value)])
|
|
(values prefix
|
|
(sort (idstring<? prefix)
|
|
(fold-left (lambda (suffix* x)
|
|
(cond
|
|
[(completion prefix (symbol->string x)) =>
|
|
(lambda (suffix) (cons suffix suffix*))]
|
|
[else suffix*]))
|
|
'() (environment-symbols (interaction-environment))))))]
|
|
[(and (fx= (fx+ c end -1) (entry-col entry))
|
|
(eq? type 'atomic)
|
|
(string? value))
|
|
(fn-completions value)]
|
|
[else (loop (fx+ c end))])))))))))
|
|
|
|
(define (should-auto-indent? ee)
|
|
(and (ee-auto-indent)
|
|
; don't autoindent if the characters are coming so fast that we're
|
|
; probably dealing with paste input
|
|
(> (- (real-time) (car (eestate-rt-last-op ee))) 50)))
|
|
)
|
|
|
|
(module (ee-read)
|
|
(define (accept ee entry kf)
|
|
(let* ([str (entry->string entry)]
|
|
[sip (open-input-string str)])
|
|
(define (fail c)
|
|
(define (report sop)
|
|
(cond
|
|
[(and (message-condition? c)
|
|
(irritants-condition? c)
|
|
(equal? (condition-message c) "~? at char ~a of ~s")
|
|
(let ([irritants (condition-irritants c)])
|
|
(and (list? irritants)
|
|
(fx= (length irritants) 4)
|
|
irritants))) =>
|
|
(lambda (irritants)
|
|
(apply
|
|
(lambda (?msg ?args fp ip)
|
|
(fprintf sop "read: ~?" ?msg ?args)
|
|
(let ([pos (index->pos str fp 0 0)])
|
|
(entry-row-set! entry (pos-row pos))
|
|
(entry-col-set! entry (pos-col pos))))
|
|
irritants))]
|
|
[else (display-condition c sop)]))
|
|
; clear entry before report has a chance to muck with point position
|
|
(clear-entry ee entry)
|
|
(ee-display-string (make-string (screen-cols) #\-))
|
|
(carriage-return)
|
|
(line-feed)
|
|
(let* ([s (let ([sop (open-output-string)])
|
|
(report sop)
|
|
(get-output-string sop))]
|
|
[n (string-length s)])
|
|
(let loop ([i 0] [msg-lines 0])
|
|
(if (= i n)
|
|
(begin
|
|
(unless (fx< (screen-rows) 3)
|
|
(ee-display-string (make-string (screen-cols) #\-))
|
|
(carriage-return)
|
|
(line-feed))
|
|
(redisplay ee entry (max (fx- (screen-rows) msg-lines 2) 1)))
|
|
(let ([m (min (fx+ i (screen-cols)) n)])
|
|
(ee-display-string (substring s i m))
|
|
(when (fx< (screen-rows) 2) (wait 2000))
|
|
(carriage-return)
|
|
(line-feed)
|
|
(loop m (fx+ msg-lines 1))))))
|
|
(kf))
|
|
(define (succeed result)
|
|
(move-eoe ee entry)
|
|
(no-raw-mode)
|
|
(ee-write-char #\newline)
|
|
(ee-flush)
|
|
(update-history! ee entry)
|
|
; skip close delimiters, whitespace, and comments, then
|
|
; save remainder of entry, if any, as histnow
|
|
(eestate-histnow-set! ee
|
|
(substring str
|
|
(let skip ([fp (file-position sip)])
|
|
(on-error fp
|
|
(let-values ([(type value start end) (read-token sip)])
|
|
(case type
|
|
[(rparen rbrack) (skip end)]
|
|
[else start]))))
|
|
(string-length str)))
|
|
(eestate-last-op-set! ee #f)
|
|
; inform encapsulated transcript port(s) if any
|
|
(let loop ([op (console-output-port)])
|
|
(when ($xscript-port? op)
|
|
(let-values ([(ip op xp) ($constituent-ports op)])
|
|
(unless (port-closed? xp) (echo-entry ee entry xp))
|
|
(loop op))))
|
|
result)
|
|
((guard (c [#t (lambda () (fail c))])
|
|
(let ([x (read sip)])
|
|
(lambda () (succeed x)))))))
|
|
|
|
(define (dispatch ee entry table)
|
|
(if (ee-winch?)
|
|
(begin
|
|
(handle-winch ee entry)
|
|
(dispatch ee entry table))
|
|
(let ([c (ee-read-char)])
|
|
(let ([x (if (eof-object? c)
|
|
(lambda (ee entry c) #f)
|
|
(hashtable-ref table c ee-insert-self))])
|
|
(cond
|
|
[(procedure? x)
|
|
(let ([n (eestate-repeat-count ee)])
|
|
(eestate-repeat-count-set! ee 1)
|
|
(if (= n 0)
|
|
(dispatch ee entry base-dispatch-table)
|
|
(let loop ([n n] [entry entry])
|
|
(cond
|
|
[(x ee entry c) =>
|
|
(lambda (entry)
|
|
(if (> n 1)
|
|
(loop (- n 1) entry)
|
|
(begin
|
|
(eestate-rt-last-op-set! ee
|
|
(cons (cdr (eestate-rt-last-op ee))
|
|
(real-time)))
|
|
(eestate-last-op-set! ee x)
|
|
(dispatch ee entry base-dispatch-table))))]
|
|
[else
|
|
(accept ee entry
|
|
(lambda ()
|
|
(dispatch ee entry base-dispatch-table)))]))))]
|
|
[(dispatch-table? x) (dispatch ee entry x)]
|
|
[else
|
|
(eestate-repeat-count-set! ee 1)
|
|
(eestate-last-op-set! ee #f)
|
|
(beep "unbound key")
|
|
(dispatch ee entry base-dispatch-table)])))))
|
|
|
|
(define (ee-read ee)
|
|
(screen-resize!)
|
|
(let ([entry (let ([s (eestate-histnow ee)])
|
|
; set to "" so that entry will appear modified if nonempty,
|
|
; i.e., if a partial entry is left over from last read
|
|
(eestate-histnow-set! ee "")
|
|
(string->entry ee s))])
|
|
(raw-mode)
|
|
(carriage-return)
|
|
(redisplay ee entry)
|
|
(move-eol ee entry)
|
|
(guard (c [#t (carriage-return)
|
|
(line-feed)
|
|
(clear-eos)
|
|
(ee-flush)
|
|
(no-raw-mode)
|
|
(ee-display-string
|
|
(call-with-string-output-port
|
|
(lambda (p)
|
|
(display-condition c p))))
|
|
(ee-write-char #\newline)
|
|
(update-history! ee entry)
|
|
(void)])
|
|
(dispatch ee entry base-dispatch-table)))))
|
|
|
|
(define (ee-prompt-and-read ee n)
|
|
(unless (and (integer? n) (>= n 0))
|
|
($oops 'ee-prompt-and-read
|
|
"nesting level ~s is not a positive integer"
|
|
n))
|
|
(if (and (let f ([ip (console-input-port)])
|
|
(or (eq? ip #%$console-input-port)
|
|
(and ($xscript-port? ip)
|
|
(let-values ([(ip op xp) ($constituent-ports ip)])
|
|
(f ip)))))
|
|
(let f ([op (console-output-port)])
|
|
(or (eq? op #%$console-output-port)
|
|
(and ($xscript-port? op)
|
|
(let-values ([(ip op xp) ($constituent-ports op)])
|
|
(f op))))))
|
|
(begin
|
|
; fresh-line doesn't take into account output written to the console
|
|
; through some other port or external means, so this might not emit a
|
|
; fresh line when one is needed, but the user can always redisplay
|
|
(fresh-line (console-output-port))
|
|
(flush-output-port (console-output-port))
|
|
(eestate-prompt-set! ee
|
|
(let ([wps (waiter-prompt-string)])
|
|
(if (string=? wps "")
|
|
""
|
|
(string-append
|
|
(apply string-append (make-list n wps))
|
|
" "))))
|
|
(ee-read ee))
|
|
(default-prompt-and-read n)))
|
|
|
|
;;; history functions
|
|
|
|
(module (history-search-bwd history-search-fwd
|
|
update-history! history-fast-forward! entry-modified?
|
|
ee-save-history ee-load-history)
|
|
(define search
|
|
(lambda (ee pred? get-bwd set-bwd! get-fwd set-fwd!)
|
|
(let loop ([bwd (get-bwd ee)]
|
|
[now (eestate-histnow ee)]
|
|
[fwd (get-fwd ee)])
|
|
(and (not (null? bwd))
|
|
(let ([s (car bwd)])
|
|
(if (pred? s)
|
|
(begin
|
|
(set-bwd! ee (cdr bwd))
|
|
(eestate-histnow-set! ee s)
|
|
(set-fwd! ee (cons now fwd))
|
|
s)
|
|
(loop (cdr bwd) s (cons now fwd))))))))
|
|
|
|
(define history-search-bwd
|
|
(lambda (ee pred?)
|
|
(search ee pred? eestate-histbwd eestate-histbwd-set!
|
|
eestate-histfwd eestate-histfwd-set!)))
|
|
|
|
(define history-search-fwd
|
|
(lambda (ee pred?)
|
|
(search ee pred? eestate-histfwd eestate-histfwd-set!
|
|
eestate-histbwd eestate-histbwd-set!)))
|
|
|
|
(define history->list
|
|
(lambda (ee)
|
|
(cdr `(,@(reverse (eestate-histfwd ee))
|
|
,(eestate-histnow ee)
|
|
,@(eestate-histbwd ee)))))
|
|
|
|
(define trim-history
|
|
(lambda (ls)
|
|
(let ([n (ee-history-limit)])
|
|
(if (> (length ls) n)
|
|
(list-head ls n)
|
|
ls))))
|
|
|
|
(define update-history!
|
|
(lambda (ee entry)
|
|
(define (all-whitespace? s)
|
|
(let ([n (string-length s)])
|
|
(let f ([i 0])
|
|
(or (fx= i n)
|
|
(and (memv (string-ref s i) '(#\space #\newline))
|
|
(f (fx+ i 1)))))))
|
|
(let ([s (entry->string entry)] [ls (history->list ee)])
|
|
(eestate-histbwd-set! ee
|
|
(if (or (all-whitespace? s)
|
|
(and (not (null? ls))
|
|
(equal? s (car ls))))
|
|
ls
|
|
(begin
|
|
(eestate-histnew-set! ee (fx+ (eestate-histnew ee) 1))
|
|
(trim-history (cons s ls))))))
|
|
(eestate-histnow-set! ee "")
|
|
(eestate-histfwd-set! ee '())))
|
|
|
|
(define history-fast-forward!
|
|
(lambda (ee)
|
|
(eestate-histbwd-set! ee (history->list ee))
|
|
(eestate-histnow-set! ee "")
|
|
(eestate-histfwd-set! ee '())))
|
|
|
|
(define (entry-modified? ee entry)
|
|
(not (string=? (entry->string entry) (eestate-histnow ee))))
|
|
|
|
(module (ee-save-history ee-load-history)
|
|
(define read-history
|
|
(lambda (ip)
|
|
(on-error #f
|
|
(let loop ([ls '()])
|
|
(let ([x (read ip)])
|
|
(if (eof-object? x)
|
|
ls
|
|
(begin
|
|
(unless (string? x) ($oops #f "oops"))
|
|
(loop (cons x ls)))))))))
|
|
|
|
(define ee-save-history
|
|
(lambda (ee filename)
|
|
(unless (string? filename)
|
|
($oops 'ee-save "~s is not a string" filename))
|
|
(let* ([iop ($open-file-input/output-port 'expeditor filename
|
|
(file-options exclusive no-fail no-truncate)
|
|
(buffer-mode block)
|
|
(make-transcoder (utf-8-codec)))]
|
|
[ls (let ([curls (history->list ee)])
|
|
(cond
|
|
[(read-history iop) =>
|
|
(lambda (savls)
|
|
(trim-history
|
|
(append
|
|
(list-head curls (eestate-histnew ee))
|
|
savls)))]
|
|
[else curls]))])
|
|
(truncate-file iop)
|
|
(fprintf iop "~
|
|
;;; This file contains a saved history for the (Petite) Chez Scheme~@
|
|
;;; expression editor. The history is represented as a sequence of~@
|
|
;;; strings, each representing a history entry, with the most recent~@
|
|
;;; entries listed last.~@
|
|
~@
|
|
;;; Exit each Scheme session running the expression editor before~@
|
|
;;; saving changes so they aren't wiped out when the session ends.\n\n")
|
|
(for-each (lambda (s) (fprintf iop "~s\n" s)) (reverse ls))
|
|
(close-port iop))))
|
|
|
|
(define ee-load-history
|
|
(lambda (ee filename)
|
|
(unless (string? filename)
|
|
($oops 'ee-load-history "~s is not a string" filename))
|
|
(let* ([iop ($open-file-input/output-port 'expeditor filename
|
|
(file-options exclusive no-fail no-truncate)
|
|
(buffer-mode block)
|
|
(make-transcoder (utf-8-codec)))]
|
|
[ls (read-history iop)])
|
|
(close-port iop)
|
|
(unless ls
|
|
($oops 'ee-load-history "missing or malformed history file ~s"
|
|
filename))
|
|
(eestate-histnew-set! ee 0)
|
|
(eestate-histbwd-set! ee ls)
|
|
(eestate-histnow-set! ee "")
|
|
(eestate-histfwd-set! ee '())))))
|
|
)
|
|
|
|
;;; editing functions
|
|
|
|
(module (ee-next-id-completion ee-next-id-completion/indent)
|
|
(define complete
|
|
(lambda (ee entry suffix*)
|
|
(eestate-last-suffix*-set! ee suffix*)
|
|
(if (null? suffix*)
|
|
(beep "id-completion: no completion found")
|
|
(insert-string-before ee entry (car suffix*)))))
|
|
|
|
(define next-completion
|
|
(lambda (ee entry)
|
|
(if (fx<= (length (eestate-last-suffix* ee)) 1)
|
|
(beep "id-completion: no completion found")
|
|
(let ([suffix (car (eestate-last-suffix* ee))])
|
|
(let ([n (string-length suffix)])
|
|
(move-left ee entry n)
|
|
(delete-forward ee entry (entry-row entry) (fx+ (entry-col entry) n)))
|
|
(complete ee entry
|
|
(append (cdr (eestate-last-suffix* ee)) (list suffix)))))))
|
|
|
|
(define ee-next-id-completion
|
|
(lambda (ee entry c)
|
|
(if (eq? (eestate-last-op ee) ee-next-id-completion)
|
|
(next-completion ee entry)
|
|
(let-values ([(prefix suffix*) (id-completions ee entry)])
|
|
(if prefix
|
|
(complete ee entry suffix*)
|
|
(begin
|
|
(eestate-last-suffix*-set! ee '())
|
|
(beep "id-completion: no identifier to complete")))))
|
|
entry))
|
|
|
|
(define ee-next-id-completion/indent
|
|
(lambda (ee entry c)
|
|
(cond
|
|
[(and (eq? (eestate-last-op ee) ee-next-id-completion/indent)
|
|
(eestate-cc? ee))
|
|
(next-completion ee entry)
|
|
entry]
|
|
[(and (or (eq? (eestate-last-op ee) ee-insert-self)
|
|
(eq? (eestate-last-op ee) ee-next-id-completion/indent))
|
|
(let-values ([(prefix suffix*) (id-completions ee entry)])
|
|
(and prefix suffix*))) =>
|
|
(lambda (suffix*)
|
|
(eestate-cc?-set! ee #t)
|
|
(complete ee entry suffix*)
|
|
entry)]
|
|
[else
|
|
(eestate-cc?-set! ee #f)
|
|
(eestate-last-suffix*-set! ee '())
|
|
(ee-indent ee entry c)])))
|
|
)
|
|
|
|
(module (ee-id-completion ee-id-completion/indent)
|
|
(define (display-completions prefix suffix*)
|
|
(let* ([s* (map (lambda (suffix) (string-append prefix suffix)) suffix*)]
|
|
[width (fx+ (apply fxmax (map string-length s*)) 2)]
|
|
[tcols (fxmax 1 (fxquotient (screen-cols) width))]
|
|
[trows (fxquotient (length s*) tcols)]
|
|
[nlong (fxremainder (length s*) tcols)])
|
|
(define (display-row v last)
|
|
(let loop ([j 0])
|
|
(let ([s (vector-ref v j)])
|
|
(if (fx= j last)
|
|
(ee-display-string s)
|
|
(begin
|
|
(ee-display-string (format "~va" width s))
|
|
(loop (fx+ j 1))))))
|
|
(carriage-return)
|
|
(line-feed))
|
|
(let ([v (make-vector (if (fx= nlong 0) trows (fx+ trows 1)))])
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i (vector-length v)))
|
|
(vector-set! v i (make-vector tcols #f)))
|
|
(let f ([s* s*] [i 0] [j 0] [nlong nlong])
|
|
(unless (null? s*)
|
|
(if (fx= i (if (fx> nlong 0) (fx+ trows 1) trows))
|
|
(f s* 0 (fx+ j 1) (fx- nlong 1))
|
|
(begin
|
|
(vector-set! (vector-ref v i) j (car s*))
|
|
(f (cdr s*) (fx+ i 1) j nlong)))))
|
|
(do ([i 0 (fx+ i 1)])
|
|
((fx= i trows))
|
|
(display-row (vector-ref v i) (fx- tcols 1)))
|
|
(unless (fx= nlong 0)
|
|
(display-row (vector-ref v trows) (fx- nlong 1)))
|
|
(if (fx= nlong 0) trows (fx+ trows 1)))))
|
|
|
|
(define (common-prefix s*)
|
|
(let outer ([s1 (car s*)] [s* (cdr s*)])
|
|
(if (null? s*)
|
|
s1
|
|
(let ([s2 (car s*)])
|
|
(let ([n1 (string-length s1)] [n2 (string-length s2)])
|
|
(let inner ([i 0])
|
|
(if (or (fx= i n1)
|
|
(fx= i n2)
|
|
(not (char=? (string-ref s1 i) (string-ref s2 i))))
|
|
(outer (substring s1 0 i) (cdr s*))
|
|
(inner (fx+ i 1)))))))))
|
|
|
|
(define ee-id-completion
|
|
(lambda (ee entry c)
|
|
(let-values ([(prefix suffix*) (id-completions ee entry)])
|
|
(if prefix
|
|
(if (not (null? suffix*))
|
|
(if (eq? (eestate-last-op ee) ee-id-completion)
|
|
(begin
|
|
(clear-entry ee entry)
|
|
(ee-display-string (make-string (screen-cols) #\-))
|
|
(carriage-return)
|
|
(line-feed)
|
|
(let ([nrows (display-completions prefix suffix*)])
|
|
(ee-display-string (make-string (screen-cols) #\-))
|
|
(carriage-return)
|
|
(line-feed)
|
|
(redisplay ee entry (max (fx- (screen-rows) nrows 1) 1))))
|
|
(insert-string-before ee entry (common-prefix suffix*)))
|
|
(beep "id-completion: no completions found"))
|
|
(beep "id-completion: no identifier to complete")))
|
|
entry))
|
|
|
|
(define ee-id-completion/indent
|
|
(lambda (ee entry c)
|
|
(cond
|
|
[(and (eq? (eestate-last-op ee) ee-id-completion/indent)
|
|
(eestate-cc? ee))
|
|
(let-values ([(prefix suffix*) (id-completions ee entry)])
|
|
(if (not (null? suffix*))
|
|
(begin
|
|
(clear-entry ee entry)
|
|
(ee-display-string (make-string (screen-cols) #\-))
|
|
(carriage-return)
|
|
(line-feed)
|
|
(let ([nrows (display-completions prefix suffix*)])
|
|
(ee-display-string (make-string (screen-cols) #\-))
|
|
(carriage-return)
|
|
(line-feed)
|
|
(redisplay ee entry (max (fx- (screen-rows) nrows 1) 1))))
|
|
(beep "id-completion: no completions found")))
|
|
entry]
|
|
[(and (or (eq? (eestate-last-op ee) ee-insert-self)
|
|
(eq? (eestate-last-op ee) ee-id-completion/indent))
|
|
(let-values ([(prefix suffix*) (id-completions ee entry)])
|
|
(and prefix suffix*))) =>
|
|
(lambda (suffix*)
|
|
(eestate-cc?-set! ee #t)
|
|
(if (not (null? suffix*))
|
|
(insert-string-before ee entry (common-prefix suffix*))
|
|
(beep "id-completion: no completions found"))
|
|
entry)]
|
|
[else
|
|
(eestate-cc?-set! ee #f)
|
|
(ee-indent ee entry c)])))
|
|
)
|
|
|
|
(define ee-insert-self
|
|
(lambda (ee entry c)
|
|
(add-char ee entry c)
|
|
entry))
|
|
|
|
(define ee-command-repeat
|
|
(lambda (ee entry c)
|
|
(define (digit-value c) (char- c #\0))
|
|
(eestate-repeat-count-set! ee
|
|
(let ([c (ee-peek-char)])
|
|
(if (and (not (eof-object? c)) (char-numeric? c))
|
|
(let loop ([n (digit-value (ee-read-char))])
|
|
(let ([c (ee-peek-char)])
|
|
(if (and (not (eof-object? c)) (char-numeric? c))
|
|
(loop (+ (* n 10) (digit-value (ee-read-char))))
|
|
n)))
|
|
(ee-default-repeat))))
|
|
entry))
|
|
|
|
(module (ee-history-bwd ee-history-fwd
|
|
ee-history-bwd-prefix ee-history-fwd-prefix
|
|
ee-history-bwd-contains ee-history-fwd-contains)
|
|
(define contains?
|
|
(lambda (key str)
|
|
(let ([key-len (string-length key)]
|
|
[str-len (string-length str)])
|
|
(let loop ([idx 0])
|
|
(cond
|
|
[(fx> key-len (fx- str-len idx)) #f]
|
|
[(string=? key (substring str idx (fx+ idx key-len))) #t]
|
|
[else (loop (add1 idx))])))))
|
|
|
|
(define prefix?
|
|
(lambda (key str)
|
|
(let ([nkey (string-length key)] [nstr (string-length str)])
|
|
; if key doesn't start with space, skip leading spaces in str
|
|
(let ([i (if (or (fx= nkey 0) (char=? (string-ref key 0) #\space))
|
|
0
|
|
(let f ([i 0])
|
|
(if (or (fx= i nstr) (not (char=? (string-ref str i) #\space)))
|
|
i
|
|
(f (fx+ i 1)))))])
|
|
(let ([n (fx+ nkey i)])
|
|
(and (fx<= n nstr)
|
|
(string=? key (substring str i n))))))))
|
|
|
|
(define new-entry
|
|
(lambda (ee entry s)
|
|
(clear-entry ee entry)
|
|
(let ([entry (string->entry ee s)])
|
|
(redisplay ee entry 1)
|
|
(move-eol ee entry)
|
|
entry)))
|
|
|
|
(define ee-history-bwd
|
|
(lambda (ee entry c)
|
|
(cond
|
|
[(and (not (null-entry? entry)) (entry-modified? ee entry))
|
|
(beep "cannot leave nonempty modified entry")
|
|
entry]
|
|
[(history-search-bwd ee (lambda (s) #t)) =>
|
|
(lambda (s)
|
|
; clear histkey when null as favor to search commands
|
|
(when (null-entry? entry) (eestate-histkey-set! ee ""))
|
|
(new-entry ee entry s))]
|
|
[else
|
|
(beep "invalid history movement")
|
|
entry])))
|
|
|
|
(define ee-history-fwd
|
|
(lambda (ee entry c)
|
|
(cond
|
|
[(and (not (null-entry? entry)) (entry-modified? ee entry))
|
|
(beep "cannot leave nonempty modified entry")
|
|
entry]
|
|
[(history-search-fwd ee (lambda (s) #t)) =>
|
|
(lambda (s)
|
|
; clear histkey when null as favor to search commands
|
|
(when (null-entry? entry) (eestate-histkey-set! ee ""))
|
|
(new-entry ee entry s))]
|
|
[else
|
|
(beep "invalid history movement")
|
|
entry])))
|
|
|
|
(define history-search-bwd-key
|
|
(lambda (ee entry match?)
|
|
(if (or (entry-modified? ee entry) (null-entry? entry))
|
|
(begin
|
|
(history-fast-forward! ee)
|
|
(eestate-histkey-set! ee (entry->string entry))
|
|
(cond
|
|
[(history-search-bwd ee
|
|
(lambda (s) (match? (eestate-histkey ee) s))) =>
|
|
(lambda (s) (new-entry ee entry s))]
|
|
[else
|
|
(beep "invalid history movement")
|
|
entry]))
|
|
; if nonempty and unmodified, we must already have moved via one
|
|
; of the history commands, so eestate-histkey should be valid
|
|
(cond
|
|
[(history-search-bwd ee
|
|
(lambda (s) (match? (eestate-histkey ee) s))) =>
|
|
(lambda (s) (new-entry ee entry s))]
|
|
[else
|
|
(beep "invalid history movement")
|
|
entry]))))
|
|
|
|
(define history-search-fwd-key
|
|
; similar to history-search-bwd-key but "finds" key at forward extreme
|
|
(lambda (ee entry match?)
|
|
(if (or (entry-modified? ee entry) (null-entry? entry))
|
|
(begin
|
|
(history-fast-forward! ee)
|
|
(eestate-histkey-set! ee (entry->string entry))
|
|
(cond
|
|
[(history-search-fwd ee
|
|
(lambda (s) (prefix? (eestate-histkey ee) s))) =>
|
|
(lambda (s) (new-entry ee entry s))]
|
|
[else
|
|
(beep "invalid history movement")
|
|
entry]))
|
|
; if nonempty and unmodified, we must already have moved via one
|
|
; of the history commands, so eestate-histkey should be valid
|
|
(cond
|
|
[(history-search-fwd ee
|
|
(lambda (s) (match? (eestate-histkey ee) s))) =>
|
|
(lambda (s) (new-entry ee entry s))]
|
|
[else
|
|
(let ([entry (new-entry ee entry (eestate-histkey ee))])
|
|
(history-fast-forward! ee)
|
|
entry)]))))
|
|
|
|
(define ee-history-fwd-prefix
|
|
(lambda (ee entry c)
|
|
(history-search-fwd-key ee entry prefix?)))
|
|
|
|
(define ee-history-bwd-prefix
|
|
(lambda (ee entry c)
|
|
(history-search-bwd-key ee entry prefix?)))
|
|
|
|
(define ee-history-fwd-contains
|
|
(lambda (ee entry c)
|
|
(history-search-fwd-key ee entry contains?)))
|
|
|
|
(define ee-history-bwd-contains
|
|
(lambda (ee entry c)
|
|
(history-search-bwd-key ee entry contains?)))
|
|
)
|
|
|
|
(define ee-newline/accept
|
|
(lambda (ee entry c)
|
|
(cond
|
|
[(null-entry? entry) entry]
|
|
; #f tells ee-read to return expr
|
|
[(and (find-next-sexp-forward ee entry 0 0 #t)
|
|
(only-whitespace-left? ee entry))
|
|
(let loop ()
|
|
(delete-to-eol ee entry)
|
|
(unless (last-line? ee entry)
|
|
(join-rows ee entry)
|
|
(loop)))
|
|
#f]
|
|
[else
|
|
(insert-strings-before ee entry '("" ""))
|
|
(when (should-auto-indent? ee) (indent ee entry))
|
|
entry])))
|
|
|
|
(define ee-newline
|
|
(lambda (ee entry c)
|
|
(cond
|
|
[(null-entry? entry) entry]
|
|
[else
|
|
(insert-strings-before ee entry '("" ""))
|
|
(when (should-auto-indent? ee) (indent ee entry))
|
|
entry])))
|
|
|
|
(define ee-accept
|
|
(lambda (ee entry c)
|
|
; force ee-read to attempt read even if not at end of expr and not balanced
|
|
(on-error #f
|
|
(let ([sip (open-input-string (entry->string entry))])
|
|
(let loop ()
|
|
(let-values ([(type value start end) (read-token sip)])
|
|
(cond
|
|
[(eq? type 'eof)
|
|
; entry contains only whitespace and comments. pretend to accept
|
|
; but don't really, or ee-read will return eof, causing cafe to exit
|
|
(update-history! ee entry)
|
|
(move-eoe ee entry)
|
|
(no-raw-mode)
|
|
(ee-write-char #\newline)
|
|
(ee-flush)
|
|
(raw-mode)
|
|
(let ([entry (string->entry ee "")])
|
|
(redisplay ee entry)
|
|
entry)]
|
|
[(and (eq? type 'quote) (eq? value 'datum-comment))
|
|
(read sip)
|
|
(loop)]
|
|
[else #f])))))))
|
|
|
|
(define ee-open-line
|
|
(lambda (ee entry c)
|
|
(let ([point (entry-point entry)])
|
|
(insert-strings-before ee entry '("" ""))
|
|
(when (should-auto-indent? ee) (indent ee entry))
|
|
(goto ee entry point)
|
|
entry)))
|
|
|
|
(define ee-indent
|
|
(lambda (ee entry c)
|
|
(indent ee entry)
|
|
entry))
|
|
|
|
(define ee-indent-all
|
|
(lambda (ee entry c)
|
|
(indent-all ee entry)
|
|
entry))
|
|
|
|
(define ee-backward-char
|
|
(lambda (ee entry c)
|
|
(if (beginning-of-line? ee entry)
|
|
(unless (first-line? ee entry)
|
|
(move-up ee entry)
|
|
(move-eol ee entry))
|
|
(move-left ee entry))
|
|
entry))
|
|
|
|
(define ee-forward-char
|
|
(lambda (ee entry c)
|
|
(if (end-of-line? ee entry)
|
|
(unless (last-line? ee entry)
|
|
(move-down ee entry)
|
|
(move-bol ee entry))
|
|
(move-right ee entry))
|
|
entry))
|
|
|
|
(define ee-next-line
|
|
(lambda (ee entry c)
|
|
(if (last-line? ee entry)
|
|
(ee-history-fwd ee entry c)
|
|
(begin
|
|
(move-down ee entry)
|
|
entry))))
|
|
|
|
(define ee-previous-line
|
|
(lambda (ee entry c)
|
|
(if (first-line? ee entry)
|
|
(ee-history-bwd ee entry c)
|
|
(begin
|
|
(move-up ee entry)
|
|
entry))))
|
|
|
|
(define ee-end-of-line
|
|
(lambda (ee entry c)
|
|
(move-eol ee entry)
|
|
entry))
|
|
|
|
(define ee-beginning-of-line
|
|
(lambda (ee entry c)
|
|
(move-bol ee entry)
|
|
entry))
|
|
|
|
(define ee-beginning-of-entry
|
|
(lambda (ee entry c)
|
|
(goto ee entry (make-pos 0 0))
|
|
entry))
|
|
|
|
(define ee-end-of-entry
|
|
(lambda (ee entry c)
|
|
(move-eoe ee entry)
|
|
entry))
|
|
|
|
(define ee-delete-to-eol
|
|
(lambda (ee entry c)
|
|
(if (end-of-line? ee entry)
|
|
(unless (last-line? ee entry)
|
|
(join-rows ee entry)
|
|
(eestate-killbuf-set! ee
|
|
(if (eq? (eestate-last-op ee) ee-delete-to-eol)
|
|
(append (eestate-killbuf ee) '(""))
|
|
'(""))))
|
|
(eestate-killbuf-set! ee
|
|
(let ([killbuf (delete-to-eol ee entry)])
|
|
(if (eq? (eestate-last-op ee) ee-delete-to-eol)
|
|
; last addition must have been ("") representing newline
|
|
(append (reverse (cdr (reverse (eestate-killbuf ee))))
|
|
killbuf)
|
|
killbuf))))
|
|
entry))
|
|
|
|
(define ee-delete-line
|
|
(lambda (ee entry c)
|
|
(if (and (first-line? ee entry)
|
|
(not (last-line? ee entry))
|
|
(last-line-displayed? ee entry))
|
|
(ee-delete-entry ee entry c)
|
|
(begin
|
|
(move-bol ee entry)
|
|
(let ([killbuf (delete-to-eol ee entry)])
|
|
(unless (equal? killbuf '(""))
|
|
(eestate-killbuf-set! ee killbuf)))
|
|
entry))))
|
|
|
|
(define ee-delete-between-point-and-mark
|
|
(lambda (ee entry c)
|
|
(let ([point (entry-point entry)] [mark (entry-mark entry)])
|
|
(if mark
|
|
(unless (pos=? mark point)
|
|
(eestate-killbuf-set! ee
|
|
(if (pos<? mark (entry-point entry))
|
|
(begin
|
|
(goto ee entry mark)
|
|
(delete-forward ee entry (pos-row point) (pos-col point)))
|
|
(delete-forward ee entry (pos-row mark) (pos-col mark)))))
|
|
(beep "mark not set")))
|
|
entry))
|
|
|
|
(define ee-set-mark
|
|
(lambda (ee entry c)
|
|
(entry-mark-set! entry (entry-point entry))
|
|
entry))
|
|
|
|
(define ee-delete-entry
|
|
(lambda (ee entry c)
|
|
(unless (null-entry? entry)
|
|
(eestate-killbuf-set! ee (yank-entry ee entry)))
|
|
(clear-entry ee entry)
|
|
(let ([entry (string->entry ee "")])
|
|
(redisplay ee entry)
|
|
entry)))
|
|
|
|
(define ee-reset-entry
|
|
(lambda (ee entry c)
|
|
(history-fast-forward! ee)
|
|
(ee-delete-entry ee entry c)))
|
|
|
|
(define ee-delete-sexp
|
|
(lambda (ee entry c)
|
|
(let ([pos (find-next-sexp-forward ee entry
|
|
(entry-row entry) (entry-col entry) #f)])
|
|
(if pos
|
|
(eestate-killbuf-set! ee
|
|
(delete-forward ee entry (pos-row pos) (pos-col pos)))
|
|
(beep "end of s-expression not found")))
|
|
entry))
|
|
|
|
(define ee-backward-delete-sexp
|
|
(lambda (ee entry c)
|
|
(let ([row (entry-row entry)] [col (entry-col entry)])
|
|
(let ([pos (find-next-sexp-backward ee entry row col)])
|
|
(if pos
|
|
(begin
|
|
(goto ee entry pos)
|
|
(eestate-killbuf-set! ee (delete-forward ee entry row col)))
|
|
(beep "start of s-expression not found"))))
|
|
entry))
|
|
|
|
(define ee-redisplay
|
|
(lambda (ee entry c)
|
|
(if (eq? (eestate-last-op ee) ee-redisplay)
|
|
(clear-screen)
|
|
(clear-entry ee entry))
|
|
(redisplay ee entry)
|
|
entry))
|
|
|
|
(define ee-yank-kill-buffer
|
|
(lambda (ee entry c)
|
|
(insert-strings-before ee entry (eestate-killbuf ee))
|
|
entry))
|
|
|
|
(define ee-yank-selection
|
|
(lambda (ee entry c)
|
|
(insert-strings-before ee entry
|
|
(string->lines
|
|
(let* ([s (get-clipboard)]
|
|
[n (fx- (string-length s) 1)])
|
|
(if (and (fx>= n 0) (char=? (string-ref s n) #\newline))
|
|
(substring s 0 n)
|
|
s))))
|
|
entry))
|
|
|
|
(define ee-string-macro
|
|
(lambda (str)
|
|
(lambda (ee entry c)
|
|
(insert-string-before ee entry str)
|
|
entry)))
|
|
|
|
(define ee-eof
|
|
(lambda (ee entry c)
|
|
(cond
|
|
[(null-entry? entry) #f]
|
|
[else (beep "eof ignored except in null entry")])))
|
|
|
|
(define ee-delete-char
|
|
(lambda (ee entry c)
|
|
(cond
|
|
[(end-of-line? ee entry)
|
|
(unless (last-line? ee entry) (join-rows ee entry))
|
|
entry]
|
|
[else (delete-char ee entry) entry])))
|
|
|
|
(define ee-eof/delete-char
|
|
(lambda (ee entry c)
|
|
(cond
|
|
[(null-entry? entry)
|
|
(if (eq? (eestate-last-op ee) ee-eof/delete-char)
|
|
entry ; assume attempt to continue deleting chars
|
|
#f)]
|
|
[(end-of-line? ee entry)
|
|
(unless (last-line? ee entry) (join-rows ee entry))
|
|
entry]
|
|
[else (delete-char ee entry) entry])))
|
|
|
|
(define ee-backward-delete-char
|
|
(lambda (ee entry c)
|
|
(if (beginning-of-line? ee entry)
|
|
(unless (first-line? ee entry)
|
|
(move-up ee entry)
|
|
(move-eol ee entry)
|
|
(join-rows ee entry))
|
|
(begin
|
|
(move-left ee entry)
|
|
(delete-char ee entry)))
|
|
entry))
|
|
|
|
(define ee-insert-paren
|
|
(lambda (ee entry c)
|
|
(add-char ee entry c)
|
|
(when (or (ee-flash-parens) (ee-auto-paren-balance))
|
|
(correct&flash-matching-delimiter ee entry))
|
|
entry))
|
|
|
|
(define ee-goto-matching-delimiter
|
|
(lambda (ee entry c)
|
|
(let ([pos (find-matching-delimiter ee entry)])
|
|
(if pos
|
|
(goto ee entry pos)
|
|
(beep "matching delimiter not found")))
|
|
entry))
|
|
|
|
(define ee-flash-matching-delimiter
|
|
(lambda (ee entry c)
|
|
(let ([pos (find-matching-delimiter ee entry)])
|
|
(if pos
|
|
(flash ee entry pos)
|
|
(beep "matching delimiter not found")))
|
|
entry))
|
|
|
|
(define ee-exchange-point-and-mark
|
|
(lambda (ee entry c)
|
|
(let ([mark (entry-mark entry)])
|
|
(if mark
|
|
(begin
|
|
(entry-mark-set! entry (entry-point entry))
|
|
(goto ee entry mark))
|
|
(beep "mark not set")))
|
|
entry))
|
|
|
|
(define ee-forward-sexp
|
|
(lambda (ee entry c)
|
|
(let ([pos (find-next-sexp-forward ee entry
|
|
(entry-row entry) (entry-col entry) #f)])
|
|
(if pos
|
|
(goto ee entry pos)
|
|
(beep "end of s-expression not found")))
|
|
entry))
|
|
|
|
(define ee-backward-sexp
|
|
(lambda (ee entry c)
|
|
(let ([pos (find-next-sexp-backward ee entry
|
|
(entry-row entry) (entry-col entry))])
|
|
(if pos
|
|
(goto ee entry pos)
|
|
(beep "start of s-expression not found")))
|
|
entry))
|
|
|
|
(define ee-forward-word
|
|
(lambda (ee entry c)
|
|
(goto ee entry
|
|
(find-next-word ee entry
|
|
(entry-row entry)
|
|
(entry-col entry)))
|
|
entry))
|
|
|
|
(define ee-backward-word
|
|
(lambda (ee entry c)
|
|
(goto ee entry
|
|
(find-previous-word ee entry
|
|
(entry-row entry)
|
|
(entry-col entry)))
|
|
entry))
|
|
|
|
(define ee-forward-page
|
|
(lambda (ee entry c)
|
|
(page-down ee entry)
|
|
entry))
|
|
|
|
(define ee-backward-page
|
|
(lambda (ee entry c)
|
|
(page-up ee entry)
|
|
entry))
|
|
|
|
(define ee-suspend-process
|
|
(lambda (ee entry c)
|
|
(carriage-return)
|
|
(line-feed)
|
|
(clear-eos)
|
|
(ee-flush)
|
|
(no-raw-mode)
|
|
(pause)
|
|
(raw-mode)
|
|
(carriage-return)
|
|
(clear-eos)
|
|
(redisplay ee entry)
|
|
entry))
|
|
|
|
(define (ee-compose . p*)
|
|
(rec ee-composition
|
|
(lambda (ee entry c)
|
|
(let f ([p* p*] [entry entry])
|
|
(if (null? p*)
|
|
entry
|
|
(let ([entry ((car p*) ee entry c)])
|
|
(and entry (f (cdr p*) entry))))))))
|
|
|
|
;;; key bindings
|
|
|
|
;;; (ee-bind-key key ee-xxx)
|
|
|
|
;;; key must evaluate to a <key>, where:
|
|
;;;
|
|
;;; <key> = <char> | <key-string>
|
|
;;;
|
|
;;; <key-string> -> "<key-char>+"
|
|
;;; <key-char> ->
|
|
;;; \e escape character
|
|
;;; ^x control is applied to character x
|
|
;;; \\ backslash
|
|
;;; \^ caret
|
|
;;; <plain-char> any character other than \ or ^
|
|
;;;
|
|
;;; <char> examples:
|
|
;;;
|
|
;;; input key description byte sequence
|
|
;;; --------- ----------- -------------
|
|
;;; #\a letter 'a' 97
|
|
;;; #\^ caret 94
|
|
;;;
|
|
;;; <key-string> examples:
|
|
;;;
|
|
;;; input key contents description byte sequence
|
|
;;; --------- -------- ----------- -------------
|
|
;;; "\\ex" \ex Esc-x 27 120
|
|
;;; "^a" ^a Ctrl-A 1
|
|
;;; "\\\\" \\ backslash 92
|
|
;;; "\\^" \^ caret 94
|
|
;;; "a" a letter 'a' 97
|
|
|
|
(module (dispatch-table? base-dispatch-table ee-bind-key)
|
|
(define make-dispatch-table
|
|
(lambda ()
|
|
(make-eqv-hashtable 256)))
|
|
|
|
(define dispatch-table? hashtable?)
|
|
|
|
(define ee-bind-key
|
|
(lambda (key proc)
|
|
(unless (or (char? key)
|
|
(and (string? key) (fx> (string-length key) 0)))
|
|
($oops 'ee-bind-key "~s is not a valid key (character or nonempty string)" key))
|
|
(unless (procedure? proc)
|
|
($oops 'ee-bind-key "~s is not a procedure" proc))
|
|
|
|
(if (string? key)
|
|
(let* ([n (string-length key)])
|
|
(define (s0 table i)
|
|
(let ([c (string-ref key i)])
|
|
(case c
|
|
[(#\\) (s-backslash table (fx+ i 1))]
|
|
[(#\^) (s-caret table (fx+ i 1))]
|
|
[else (s-lookup table (fx+ i 1) c)])))
|
|
(define (s-backslash table i)
|
|
(when (fx= i n)
|
|
($oops 'ee-bind-key
|
|
"malformed key ~s (nothing following \\)"
|
|
key))
|
|
(let ([c (string-ref key i)])
|
|
(case c
|
|
[(#\e) (s-lookup table (fx+ i 1) #\esc)]
|
|
[(#\\ #\^) (s-lookup table (fx+ i 1) c)]
|
|
[else ($oops 'ee-bind-key
|
|
"malformed key ~s (unexpected character following \\)"
|
|
key)])))
|
|
(define (s-caret table i)
|
|
(define (^char c)
|
|
(integer->char (fxlogand (char->integer c) #b11111)))
|
|
(when (fx= i n)
|
|
($oops 'ee-bind-key
|
|
"malformed key ~s (nothing following ^)"
|
|
key))
|
|
(s-lookup table (fx+ i 1) (^char (string-ref key i))))
|
|
(define (s-lookup table i key)
|
|
(let ([x (hashtable-ref table key #f)])
|
|
(cond
|
|
[(fx= i n)
|
|
(when (dispatch-table? x)
|
|
(warningf 'ee-bind-key
|
|
"definition for key ~s disables its use as a prefix"
|
|
key))
|
|
(hashtable-set! table key proc)]
|
|
[(dispatch-table? x) (s0 x i)]
|
|
[else
|
|
(when (procedure? x)
|
|
(warningf 'ee-bind-key
|
|
"definition for key ~s disables its use as a prefix"
|
|
key))
|
|
(let ([x (make-dispatch-table)])
|
|
(hashtable-set! table key x)
|
|
(s0 x i))])))
|
|
(s0 base-dispatch-table 0))
|
|
(begin
|
|
(when (dispatch-table? (hashtable-ref base-dispatch-table key #f))
|
|
(warningf 'ee-bind-key
|
|
"definition for key ~s disables its use as a prefix"
|
|
key))
|
|
(hashtable-set! base-dispatch-table key proc)))))
|
|
|
|
(define base-dispatch-table (make-dispatch-table))
|
|
|
|
; set up self-insertion for space and all printing characters
|
|
(for-each
|
|
(lambda (c) (ee-bind-key c ee-insert-self))
|
|
(string->list " !\"#$%&'()*+,-./0123456789:;<=>?@ABCDEFGHIJKLMNOPQRSTUVWXYZ[\\]^_`abcdefghijklmnopqrstuvwxyz{|}~"))
|
|
)
|
|
|
|
(let ([ebk ee-bind-key])
|
|
; newline operations
|
|
(ebk #\return ee-newline/accept) ; Enter, ^M
|
|
(ebk "^J" ee-accept) ; ^J
|
|
(ebk "^O" ee-open-line) ; ^O
|
|
|
|
; indenting operations
|
|
(ebk "\\e\t" ee-indent) ; Esc-Tab
|
|
(ebk "\\eq" ee-indent-all) ; Esc-q
|
|
(ebk "\\eQ" ee-indent-all) ; Esc-Q
|
|
(ebk "\\e^Q" ee-indent-all) ; Esc-^Q
|
|
|
|
; command completion
|
|
(ebk "\t" ee-id-completion/indent) ; Tab
|
|
(ebk "^R" ee-next-id-completion) ; ^R
|
|
|
|
; cursor movement keys
|
|
(ebk "^B" ee-backward-char) ; ^B
|
|
(ebk "\\e[D" ee-backward-char) ; Left ; ]
|
|
(ebk "^F" ee-forward-char) ; ^F
|
|
(ebk "\\e[C" ee-forward-char) ; Right ; ]
|
|
(ebk "^N" ee-next-line) ; ^N
|
|
(ebk "\\e[B" ee-next-line) ; Down
|
|
(ebk "^P" ee-previous-line) ; ^P
|
|
(ebk "\\e[A" ee-previous-line) ; Up
|
|
|
|
(ebk "\\ef" ee-forward-word) ; Esc-f
|
|
(ebk "\\eF" ee-forward-word) ; Esc-F
|
|
(ebk "\\e^F" ee-forward-sexp) ; Esc-^F
|
|
(ebk "\\eb" ee-backward-word) ; Esc-b
|
|
(ebk "\\eB" ee-backward-word) ; Esc-B
|
|
(ebk "\\e^B" ee-backward-sexp) ; Esc-^B
|
|
|
|
(ebk "^X^X" ee-exchange-point-and-mark) ; ^X^X
|
|
(ebk "^X[" ee-backward-page) ; ^X[
|
|
(ebk "^X]" ee-forward-page) ; ^X]
|
|
(ebk "\\e[5~" ee-backward-page) ; Page-Up
|
|
(ebk "\\e[6~" ee-forward-page) ; Page-Down
|
|
|
|
(ebk "^E" ee-end-of-line) ; ^E
|
|
(ebk "\\e[F" ee-end-of-line) ; End key
|
|
; terminals are supposed to default to "normal" (aka "cursor") rather than
|
|
; "application" mode and in normal mode send ANSI \\e[F and \\e[H for End
|
|
; and Home. although gnome terminal apparently starts in normal mode, it
|
|
; sends the application-mode sequences for this. we capitulate reluctantly,
|
|
; since by defining Esc-OF and Esc-OH to do End and Home we prevent people
|
|
; from binding Esc-O by itself to a command.
|
|
(ebk "\\eOF" ee-end-of-line) ; End key (gnome terminal)
|
|
(ebk "\\e[4~" ee-end-of-line) ; End key (cygwin)
|
|
(ebk "^A" ee-beginning-of-line) ; ^A
|
|
(ebk "\\e[H" ee-beginning-of-line) ; Home key
|
|
(ebk "\\eOH" ee-beginning-of-line) ; Home key (gnome terminal)
|
|
(ebk "\\e[1~" ee-beginning-of-line) ; Home key (cygwin)
|
|
(ebk "\\e<" ee-beginning-of-entry) ; Esc-<
|
|
(ebk "\\e>" ee-end-of-entry) ; Esc-> ; [[
|
|
(ebk "\\e]" ee-goto-matching-delimiter) ; Esc-]
|
|
(ebk #\( ee-insert-paren) ; (
|
|
(ebk #\) ee-insert-paren) ; )
|
|
(ebk #\[ ee-insert-paren) ; [
|
|
(ebk #\] ee-insert-paren) ; ]
|
|
(ebk "^]" ee-flash-matching-delimiter) ; ^]
|
|
|
|
; destructive functions
|
|
(ebk "^U" ee-delete-line) ; ^U
|
|
(ebk "^K" ee-delete-to-eol) ; ^K
|
|
(ebk "\\ek" ee-delete-to-eol) ; Esc-k
|
|
(ebk "^W" ee-delete-between-point-and-mark) ; ^W
|
|
(ebk "^G" ee-delete-entry) ; ^G
|
|
(ebk "^C" ee-reset-entry) ; ^C
|
|
(ebk "\\e^K" ee-delete-sexp) ; Esc-^K
|
|
(ebk "\\e\\e[3~" ee-delete-sexp) ; Esc-Delete
|
|
(ebk "\\e\177" ee-backward-delete-sexp) ; Esc-Backspace
|
|
(ebk "\\e^H" ee-backward-delete-sexp) ; Esc-^H
|
|
(ebk "^V" ee-yank-selection) ; ^V
|
|
(ebk "^Y" ee-yank-kill-buffer) ; ^Y
|
|
(ebk "^D" ee-eof/delete-char) ; ^D
|
|
(ebk #\rubout ee-backward-delete-char) ; Backspace (<--)
|
|
(ebk "\\e[3~" ee-delete-char) ; Delete
|
|
(ebk "^H" ee-backward-delete-char) ; ^H
|
|
(ebk "^@" ee-set-mark) ; ^@ (or ^Space)
|
|
(ebk "^^" ee-set-mark) ; ^^
|
|
|
|
; display functions
|
|
(ebk "^L" ee-redisplay) ; ^L
|
|
|
|
; string macros
|
|
(ebk "\\ed" (ee-string-macro "(define ")) ; Esc-d ; )
|
|
(ebk "\\el" (ee-string-macro "(lambda ")) ; Esc-l ; )
|
|
|
|
; history keys
|
|
(ebk "\\e^P" ee-history-bwd) ; Esc-^P
|
|
(ebk "\\e\\e[A" ee-history-bwd) ; Esc-Up
|
|
(ebk "\\e^N" ee-history-fwd) ; Esc-^N
|
|
(ebk "\\e\\e[B" ee-history-fwd) ; Esc-Down
|
|
(ebk "\\ep" ee-history-bwd-prefix) ; Esc-p
|
|
(ebk "\\eP" ee-history-bwd-contains) ; Esc-P
|
|
(ebk "\\en" ee-history-fwd-prefix) ; Esc-n
|
|
(ebk "\\eN" ee-history-fwd-contains) ; Esc-N
|
|
|
|
; misc
|
|
(ebk "\\e^U" ee-command-repeat) ; Esc-^U
|
|
(ebk "^Z" ee-suspend-process) ; ^Z
|
|
)
|
|
|
|
(set! $expeditor
|
|
(lambda (thunk)
|
|
(let ([ee #f])
|
|
(define (expeditor-prompt-and-read n)
|
|
(if (cond
|
|
[(eestate? ee) #t]
|
|
[(eq? ee 'failed) #f]
|
|
[(init-screen)
|
|
(set! ee (make-eestate))
|
|
(let ([histfile ($expeditor-history-file)])
|
|
(when histfile
|
|
(on-error (void) (ee-load-history ee histfile))))
|
|
#t]
|
|
[else (set! ee 'failed) #f])
|
|
(ee-prompt-and-read ee n)
|
|
(default-prompt-and-read n)))
|
|
(let-values ([val* (parameterize ([waiter-prompt-and-read expeditor-prompt-and-read])
|
|
(thunk))])
|
|
(when (eestate? ee)
|
|
(let ([histfile ($expeditor-history-file)])
|
|
(when histfile
|
|
(on-error (void) (ee-save-history ee histfile)))))
|
|
(apply values val*)))))
|
|
)
|
|
|
|
) ; when-feature expeditor
|