Location: contrib, 2584 Lines
; S9E is the Scheme 9 Editor ; by Nils M Holm, 2012 ; Placed in the Public Domain ; ; (s9e string <option> ...) ==> unspecific ; (s9e) ==> unspecific ; ; The S9E procedure implements a Scheme-centric full screen text editor. ; If specified, it loads the file STRING into an editing buffer. ; ; When the 'READ-ONLY option is passed to S9E, the initial buffer will ; be read-only. ; ; (Example): (s9e "foo.scm") ; ; Todo: ; warn about expanded tabs ; CR/LF mode (require-extension sys-unix curses) (load-from-library "syntax-rules.scm") (load-from-library "define-structure.scm") (load-from-library "pretty-print.scm") (load-from-library "read-line.scm") (load-from-library "read-file.scm") (load-from-library "get-line.scm") (load-from-library "hof.scm") (load-from-library "setters.scm") (load-from-library "letcc.scm") (load-from-library "and-letstar.scm") (load-from-library "format.scm") (load-from-library "adjoin.scm") (load-from-library "remove.scm") (load-from-library "mergesort.scm") (load-from-library "string-expand.scm") (load-from-library "string-split.scm") (load-from-library "string-unsplit.scm") (load-from-library "string-position.scm") (load-from-library "string-last-position.scm") (load-from-library "string-prefixeqp.scm") (load-from-library "string-parse.scm") (load-from-library "get-prop.scm") (load-from-library "search-path.scm") (load-from-library "spawn-command.scm") (load-from-library "spawn-shell-command.scm") (load-from-library "flush-output-port.scm") ; ----- curses abstraction layer ----- (define addch curs:addch) (define addstr curs:addstr) (define attrset curs:attrset) (define beep curs:beep) (define cbreak curs:cbreak) (define clear curs:clear) (define clrtoeol curs:clrtoeol) (define cols curs:cols) (define deleteln curs:deleteln) (define echo curs:echo) (define endwin curs:endwin) (define flash curs:flash) (define getch curs:getch) (define color? curs:has-colors) (define idlok curs:idlok) (define initscr curs:initscr) (define insertln curs:insertln) (define keypad curs:keypad) (define lines curs:lines) (define move curs:move) (define mvaddstr curs:mvaddstr) (define nl curs:nl) (define noecho curs:noecho) (define nodelay curs:nodelay) (define nonl curs:nonl) (define noraw curs:noraw) (define raw curs:raw) (define refresh curs:refresh) (define scrollok curs:scrollok) (define setcolor curs:color-set) (define standend curs:standend) (define standout curs:standout) (define unctrl curs:unctrl) (define ungetch curs:ungetch) (define *black* curs:color-black) (define *blue* curs:color-blue) (define *green* curs:color-green) (define *cyan* curs:color-cyan) (define *red* curs:color-red) (define *magenta* curs:color-magenta) (define *yellow* curs:color-yellow) (define *gray* curs:color-gray) (define *attr-standout* curs:attr-standout) (define *attr-bold* curs:attr-bold) (define *attr-normal* curs:attr-normal) (define *key-up* curs:key-up) (define *key-down* curs:key-down) (define *key-left* curs:key-left) (define *key-right* curs:key-right) (define *key-ppage* curs:key-ppage) (define *key-npage* curs:key-npage) (define *key-home* curs:key-home) (define *key-end* curs:key-end) (define *key-backspace* curs:key-backspace) (define *key-delete* curs:key-dc) (define *key-insert* curs:key-ic) (define (key-pressed?) (nodelay #t) (let ((k (getch))) (nodelay #f) (if k (ungetch k)) (number? k))) ; ----- system abstraction layer ----- (define catch-errors sys:catch-errors) (define chmod sys:chmod) (define directory? sys:stat-directory?) (define make-output-port sys:make-output-port) (define fd-close sys:close) (define fd-creat sys:creat) (define fd-read sys:read) (define fd-select sys:select) (define errno sys:errno) (define errno->string sys:strerror) (define exit sys:exit) (define getcwd sys:getcwd) (define getenv sys:getenv) (define getpid sys:getpid) (define read-directory sys:readdir) (define remove-file sys:unlink) (define rename-file sys:rename) (define run-shell-command sys:system) (define send-signal sys:notify) (define stat-file sys:stat) (define stat-get-mode (compose cdr (curry assq 'mode))) (define unix-time sys:time) (define wait-for-process sys:wait) (define (file-exists? path) (sys:access path sys:access-f-ok)) (define (file-readable? path) (sys:access path sys:access-r-ok)) (define (file-writable? path) (sys:access path sys:access-w-ok)) ; ----- globals ----- (define *buffers* (list)) (define *yanked* #f) (define *switch-to* #f) (define *chunk-size* 1000) (define *offset-jump* 8) (define *spaces* "") (define *dashes* "") (define *message* #f) (define *repl* #f) (define *symbols* '()) (define *undo-mark* #f) (define (^ c) (integer->char (- (char->integer c) (char->integer #\@)))) (define ^A (^ #\A)) (define ^B (^ #\B)) (define ^C (^ #\C)) (define ^D (^ #\D)) (define ^E (^ #\E)) (define ^F (^ #\F)) (define ^G (^ #\G)) (define ^H (^ #\H)) (define ^I (^ #\I)) (define ^J (^ #\J)) (define ^K (^ #\K)) (define ^L (^ #\L)) (define ^M (^ #\M)) (define ^N (^ #\N)) (define ^O (^ #\O)) (define ^P (^ #\P)) (define ^Q (^ #\Q)) (define ^R (^ #\R)) (define ^S (^ #\S)) (define ^T (^ #\T)) (define ^U (^ #\U)) (define ^V (^ #\V)) (define ^W (^ #\W)) (define ^X (^ #\X)) (define ^Y (^ #\Y)) (define ^Z (^ #\Z)) (define LP #\() (define RP #\)) (define LB #\[) (define RB #\]) (define *properties* '(("ai" auto-indent global #t) ("al" auto-load local #F) ("ct" color-text global "gray/blue") ("cr" color-region global "gray/red") ("cs" color-status global "blue/cyan") ("ci" color-info global "gray/green") ("ce" color-error global "black/yellow") ("cp" color-paren global "blue/yellow") ("eb" error-bell global #t) ("hr" help-reminder global #t) ("lt" load-timeout global 10) ("ro" read-only local #F) ("rc" repl-command global "s9 -q") ("ri" repl-init global "") ("rt" repl-timeout global 5) ("sc" sense-case global #F) ("sm" show-match global #t) ("" scheme-repl internal #F) ("" transient internal #F))) (define prop-abbr car) (define prop-prop cadr) (define prop-scope caddr) (define prop-default cadddr) (define *globals* (list)) (define (property x) (get-prop *globals* x)) ; ----- editing buffer structure ----- (define-structure buffer (name #f) (properties (list)) (length 1) (y 0) (x 0) (col 0) (top 0) (off 0) (mark #f) (reg0 #f) (regn #f) (searchstr "") (undo '()) (redo '()) (last-char #f) (buf (make-vector *chunk-size* ""))) (define (reset-undo! buf) (buffer-set-undo! buf '()) (buffer-set-redo! buf '())) (define (buf-line buf pos) (if (>= pos (buffer-length buf)) "" (vector-ref (buffer-buf buf) pos))) (define (buf-cur-line buf) (buf-line buf (buffer-y buf))) (define (buf-cur-length buf) (string-length (buf-cur-line buf))) (define (buf-cur-char buf) (if (>= (buffer-x buf) (buf-cur-length buf)) #f (string-ref (buf-cur-line buf) (buffer-x buf)))) (define (buf-prop? buf p) (get-prop (buffer-properties buf) p)) (define (buf-set-prop! buf p) (buffer-set-properties! buf (put-prop (buffer-properties buf) p #t))) (define (buf-rem-prop! buf p) (buffer-set-properties! buf (rem-prop (buffer-properties buf) p))) (define (modified! buf) (buf-set-prop! buf 'modified)) (define (modified? buf) (and (buf-prop? buf 'modified) (not (buf-prop? buf 'scheme-repl)))) (define (read-only? buf) (buf-prop? buf 'read-only)) (define (end-of-buf? buf) (and (>= (buffer-y buf) (- (buffer-length buf) 1)) (not (buf-cur-char buf)))) (define (top-of-buf? buf) (and (zero? (buffer-y buf)) (zero? (buffer-x buf)))) (define (sync-mark buf) (if (not (buffer-mark buf)) (buffer-set-regn! buf (list (buffer-x buf) (buffer-y buf))))) ; ----- buffer management ----- (define (fresh-buffer props) (let ((b (make-buffer #f '()))) (for-each (curry buf-set-prop! b) props) (set! *buffers* (append *buffers* (list b))) b)) (define (delete-buffer buf) (set! *buffers* (remq buf *buffers*))) (define (nth-buffer n) (do ((n n (- n 1)) (b *buffers* (cdr b))) ((zero? n) (car b)))) (define (this-buffer buf) (let find ((b *buffers*)) (cond ((null? b) #f) ((eq? buf (car b)) b) (else (find (cdr b)))))) (define (find-buffer tag . create) (let find ((b *buffers*)) (cond ((null? b) (if (null? create) #f (fresh-buffer (list tag)))) ((buf-prop? (car b) tag) (car b)) (else (find (cdr b)))))) (define (modified-buffers) (do ((n 0 (if (modified? (car b)) (+ 1 n) n)) (b *buffers* (cdr b))) ((null? b) n))) ; ----- buffer I/O ----- (define (change-line! buf pos line) (if (>= pos (vector-length (buffer-buf buf))) (let ((newsize (* *chunk-size* (+ 1 (quotient pos *chunk-size*))))) (let ((new (make-vector newsize "")) (old (buffer-buf buf)) (len (vector-length (buffer-buf buf)))) (do ((i 0 (+ 1 i))) ((>= i len)) (vector-set! new i (vector-ref old i))) (buffer-set-buf! buf new)))) (if (>= pos (buffer-length buf)) (buffer-set-length! buf (+ 1 pos))) (vector-set! (buffer-buf buf) pos line)) (define (clear-buffer buf) (change-line! buf 0 "") (buffer-set-length! buf 1) (let ((al (buf-prop? buf 'auto-load))) (buffer-set-properties! buf '()) (if al (buf-set-prop! buf 'auto-load))) (move-to buf 0 0 0)) (define (load-buffer buf path . silent) (buffer-set-name! buf path) (if (not (file-readable? path)) (err "new file: ~A" path) (with-input-from-file path (lambda () (reset-undo! buf) (let load ((line (read-line)) (pos 0)) (cond ((eof-object? line) (go-to buf 0 0 0) (set! *message* #f) (if (null? silent) (begin (if (not (file-writable? path)) (begin (buf-set-prop! buf 'read-only) (err "file is read-only")) (status-line buf)) (show-buffer buf)))) (else (let ((line (string-expand line))) (if (zero? (remainder pos 100)) (info "~D lines loaded" pos)) (change-line! buf pos line) (load (read-line) (+ 1 pos)))))))))) (define (save-buffer buf path . range) (catch-errors #t) (let* ((tmpname (string-append path "." (number->string (getpid)) ".tmp"))) (if (file-exists? tmpname) (remove-file tmpname)) (if (not (let ((fd (fd-creat tmpname))) (if fd (fd-close fd)) fd)) (begin (err (format #f "could not create file: ~A" (errno->string (errno)))) (catch-errors #f) #f) (let* ((reg0 (if (null? range) (list 0 0) (car range))) (regn (if (null? range) (list 0 (buffer-length buf)) (cadr range))) (pos0 (car reg0)) (posn (car regn)) (from (cadr reg0)) (to (cadr regn))) (remove-file tmpname) (with-output-to-file tmpname (lambda () (do ((i from (+ 1 i))) ((> i to)) (if (zero? (remainder i 100)) (info (format #f "~D lines written" i))) (cond ((= i from) (let* ((s (buf-line buf i)) (k (string-length s))) (display (substring s pos0 k)))) ((= i to) (display (substring (buf-line buf i) 0 posn))) (else (display (buf-line buf i)))) (if (not (= i to)) (newline))))) (let ((mode (cond ((stat-file path) => stat-get-mode) (else (errno) #f)))) (if (file-exists? path) (remove-file path)) (rename-file tmpname path) (if mode (chmod path mode)) (catch-errors #f) (let ((e (errno))) (cond ((not (zero? e)) (err (format #f "error writing file: ~A" (errno->string e))) #f) (else (info (format #f "~D lines written" (if (zero? posn) (- to from) (+ 1 (- to from))))) #t)))))))) ; ----- utilities ----- (define (string-cut s k) (if (> k (string-length s)) s (substring s 0 k))) (define (string-trim s k) (let ((n (string-length s))) (if (> k n) s (substring s (- n k) n)))) (define (string-skip-white s) (let ((k (string-length s))) (do ((i 0 (+ 1 i))) ((or (>= i k) (not (char=? #\space (string-ref s i)))) (substring s i k))))) (define (last x) (car (reverse x))) (define (indentation s) (let ((k (string-length s))) (do ((i 0 (+ 1 i))) ((or (>= i k) (not (char=? #\space (string-ref s i)))) i)))) ; ----- buffer display ----- (define (uncontrol k) (integer->char (+ (char->integer k) (char->integer #\@)))) (define (visual-char k) (let ((n (char->integer k))) (cond ((< n 32) (format #f "^~C" (uncontrol k))) ((= n 127) "^?") (else (string k))))) (define (screen-top) 0) (define (screen-bottom) (if (color?) (- (lines) 1) (- (lines) 2))) (define (statline-pos) (if (color?) (screen-bottom) (+ (screen-bottom) 1))) (define (screen-lines) (- (screen-bottom) (screen-top))) (define (on-screen? buf x y) (and (<= (buffer-off buf) x (+ (buffer-off buf) (cols) -1)) (<= (buffer-top buf) y (+ (buffer-top buf) (screen-lines) -1)))) (define (set-color fg/bg alt) (if (color?) (apply setcolor fg/bg) (attrset alt))) (define *color-text* (list *gray* *blue*)) (define *color-region* (list *gray* *red*)) (define *color-status* (list *blue* *cyan*)) (define *color-info* (list *gray* *green*)) (define *color-error* (list *black* *yellow*)) (define *color-paren* (list *blue* *yellow*)) (define (color-text) (set-color *color-text* *attr-normal*)) (define (color-region) (set-color *color-region* *attr-standout*)) (define (color-status) (set-color *color-status* *attr-normal*)) (define (color-info) (set-color *color-info* *attr-normal*)) (define (color-error) (set-color *color-error* *attr-bold*)) (define (color-paren) (set-color *color-paren* *attr-bold*)) (define-syntax update-color! (syntax-rules () ((_ cvar prop) (set! cvar (parse-color cvar (property 'prop)))))) (define (update-colors) (update-color! *color-text* color-text) (update-color! *color-region* color-region) (update-color! *color-status* color-status) (update-color! *color-info* color-info) (update-color! *color-error* color-error) (update-color! *color-paren* color-paren)) (define (before x y dx dy) (or (< y dy) (and (= y dy) (< x dx)))) (define (region buf) (and-let* ((r0 (buffer-reg0 buf)) (rn (buffer-regn buf)) (x0 (car r0)) (y0 (cadr r0)) (xn (car rn)) (yn (cadr rn))) (if (before x0 y0 xn yn) `((,x0 ,y0) (,xn ,yn)) `((,xn ,yn) (,x0 ,y0))))) (define (region? buf) (and (region buf) #t)) (define (region-start buf) (and-let* ((r (region buf))) (car r))) (define (region-end buf) (and-let* ((r (region buf))) (cadr r))) (define (in-region? buf x y) (and-let* ((r (region buf)) (r0 (car r)) (rn (cadr r)) (x0 (car r0)) (y0 (cadr r0)) (xn (car rn)) (yn (cadr rn))) (and (not (before x y x0 y0)) (not (before xn yn x y))))) (define (region-break? buf y) (and-let* ((r0 (buffer-reg0 buf)) (rn (buffer-regn buf))) (or (= y (cadr r0)) (= y (cadr rn))))) (define (show-region-break buf line pos len) (let* ((rs (region-start buf)) (re (region-end buf)) (b0 (if (= pos (cadr rs)) (if (< (car rs) (buffer-off buf)) (buffer-off buf) (car rs)) 0)) (bn (if (= pos (cadr re)) (car re) (+ 1 len)))) (let loop ((chars (string->list line)) (i (buffer-off buf))) (if (= i b0) (color-region)) (if (= i bn) (color-text)) (if (null? chars) (begin (addstr (substring *spaces* (string-length line) (cols))) (color-text)) (begin (addch (car chars)) (loop (cdr chars) (+ 1 i))))))) (define (show-line buf pos y) (let* ((line (buf-line buf pos)) (k (string-length line)) (line (if (< k (buffer-off buf)) "" (substring line (buffer-off buf) k))) (line (string-cut line (cols)))) (cond ((region-break? buf pos) (move y 0) (show-region-break buf line pos k)) (else (if (in-region? buf 0 pos) (color-region)) (mvaddstr y 0 line) (addstr (substring *spaces* (string-length line) (cols))) (color-text))))) (define (show-cur-line buf) (color-text) (show-line buf (buffer-y buf) (+ (- (buffer-y buf) (buffer-top buf)) (screen-top)))) (define (show-buffer buf) (color-text) (let show ((pos (buffer-top buf)) (y (screen-top))) (if (< y (screen-bottom)) (begin (show-line buf pos y) (show (+ 1 pos) (+ 1 y)))))) (define (go-to buf x y . offset) (let ((offset (if (null? offset) (quotient (screen-lines) 3) (car offset)))) (if (not (on-screen? buf x y)) (let ((top (max 0 (- y offset))) (off (max 0 (if (< x (cols)) 0 (- x *offset-jump*))))) (buffer-set-top! buf top) (buffer-set-off! buf off))) (buffer-set-x! buf x) (buffer-set-y! buf y))) (define (move-to buf x y . offset) (apply go-to buf x y offset) (update-col buf) (show-buffer buf)) (define (menu-dashes) (if (not (color?)) (mvaddstr (screen-bottom) 0 *dashes*))) (define (status-line buf) (color-status) (menu-dashes) (let* ((p (buffer-name buf)) (p (if p p "")) (k (- (cols) 30)) (s (format #f " ~C~C~C~C L:~D/~D C:~D [~A~A]~A" (if (buf-prop? buf 'auto-load) #\a #\.) (if (region? buf) #\R #\.) (if (modified? buf) #\m #\.) (if (read-only? buf) #\r #\.) (+ 1 (buffer-y buf)) (buffer-length buf) (+ 1 (buffer-x buf)) (if (> (string-length p) k) "<" "") (string-trim p k) (if (or (not (property 'help-reminder)) (buf-prop? buf 'transient)) "" " ^L = command")))) (mvaddstr (statline-pos) 0 *spaces*) (mvaddstr (statline-pos) 0 s) (set! *message* #f))) (define (message . args) (let* ((msg (apply format #f args)) (msg (string-cut msg (- (cols) 1)))) (mvaddstr (statline-pos) 0 *spaces*) (mvaddstr (statline-pos) 0 msg) (set! *message* msg) (refresh))) (define (bell) (if (property 'error-bell) (beep))) (define (err . args) (color-error) (if *message* (begin (mvaddstr (statline-pos) (+ 1 (string-length *message*)) "-- more") (getch))) (apply message args) (bell)) (define (info . args) (color-info) (apply message args)) ; ----- keyboard input ----- (define (sync-pos buf) (move (- (buffer-y buf) (buffer-top buf)) (- (buffer-x buf) (buffer-off buf)))) (define (get-key buf) (sync-pos buf) (let ((k (getch))) (if *message* (status-line buf)) (set! *message* #f) (cond ((= k *key-home*) ^A) ((= k *key-end*) ^E) ((= k *key-left*) ^B) ((= k *key-right*) ^F) ((= k *key-up*) ^P) ((= k *key-down*) ^N) ((= k *key-ppage*) ^T) ((= k *key-npage*) ^V) ((= k *key-delete*) ^D) ((= k *key-backspace*) ^H) ((= k *key-insert*) ^Y) ((<= 0 k 127) (integer->char k)) (else (err "unknown key code: <~D>" k) #f)))) ; ----- motion commands ----- (define (update-col buf) (buffer-set-col! buf (buffer-x buf))) (define (reset-col buf) (if (<= (buffer-col buf) (buf-cur-length buf)) (buffer-set-x! buf (buffer-col buf)) (buffer-set-x! buf (buf-cur-length buf)))) (define (move-to-pos0 buf) (buffer-set-x! buf 0) (update-col buf)) (define (move-to-eol buf) (buffer-set-x! buf (buf-cur-length buf)) (update-col buf)) (define (move-forward buf) (let ((max (buf-cur-length buf))) (if (< (buffer-x buf) max) (buffer-set-x! buf (+ 1 (buffer-x buf))) (if (< (buffer-y buf) (- (buffer-length buf) 1)) (begin (buffer-set-x! buf 0) (buffer-set-y! buf (+ 1 (buffer-y buf)))) (bell))) (update-col buf))) (define (move-backward buf) (if (positive? (buffer-x buf)) (buffer-set-x! buf (- (buffer-x buf) 1)) (if (positive? (buffer-y buf)) (begin (buffer-set-y! buf (- (buffer-y buf) 1)) (move-to-eol buf)) (bell))) (update-col buf)) (define (move-down buf) (if (< (buffer-y buf) (- (buffer-length buf) 1)) (buffer-set-y! buf (+ 1 (buffer-y buf)))) (reset-col buf)) (define (move-up buf) (if (positive? (buffer-y buf)) (buffer-set-y! buf (- (buffer-y buf) 1))) (reset-col buf)) (define (move-next-word buf) (let* ((word? (compose not char-whitespace?)) (ch (if (buf-cur-char buf) (buf-cur-char buf) #\space)) (skip? (cond ((word? ch) word?) ((char-whitespace? ch) (const #f)) (else (compose not word?))))) (if (end-of-buf? buf) (bell) (let loop ((ch (buf-cur-char buf))) (cond ((not ch) (if (not (end-of-buf? buf)) (begin (move-forward buf) (loop #\space)))) ((skip? ch) (move-forward buf) (loop (buf-cur-char buf))) (else (let loop ((ch (buf-cur-char buf))) (cond ((not ch) (if (not (end-of-buf? buf)) (begin (move-forward buf) (loop (buf-cur-char buf))))) ((char-whitespace? ch) (move-forward buf) (loop (buf-cur-char buf))))))))) (update-col buf))) (define (move-prev-word buf) (let ((word? (compose not char-whitespace?))) (move-backward buf) (let loop ((ch (buf-cur-char buf))) (cond ((not ch) (if (top-of-buf? buf) (bell) (begin (move-backward buf) (loop #\space)))) ((char-whitespace? ch) (move-backward buf) (loop (buf-cur-char buf))) (else (let ((skip? (if (word? ch) word? (compose not char-whitespace?)))) (let loop ((ch (buf-cur-char buf))) (cond ((and ch (not (top-of-buf? buf)) (skip? ch)) (move-backward buf) (loop (buf-cur-char buf))) (else (if (not (top-of-buf? buf)) (move-forward buf)))))))))) (update-col buf)) (define (move-next-page buf) (if (>= (+ (buffer-y buf) (screen-lines) -1) (buffer-length buf)) (buffer-set-y! buf (- (buffer-length buf) 1)) (buffer-set-y! buf (+ (buffer-y buf) (screen-lines) -1))) (if (not (negative? (- (buffer-y buf) (- (screen-lines) 1)))) (buffer-set-top! buf (- (buffer-y buf) (- (screen-lines) 1))) (buffer-set-top! buf 0)) (reset-col buf) (show-buffer buf)) (define (move-prev-page buf) (if (negative? (- (buffer-y buf) (screen-lines) -1)) (buffer-set-y! buf 0) (buffer-set-y! buf (- (buffer-y buf) (screen-lines) -1))) (buffer-set-top! buf (buffer-y buf)) (reset-col buf) (show-buffer buf)) (define (move-to-eof buf) (move-to buf 0 (- (buffer-length buf) 1) (screen-lines))) (define (move-to-line buf) (color-info) (let* ((ln (get-line (statline-pos) 0 "" "line: ")) (ln (if ln (string->number ln) #f))) (cond ((not ln)) ((not (<= 1 ln (buffer-length buf))) (err "no such line: ~D" ln)) (else (move-to buf 0 (- ln 1))))) (if (not *message*) (status-line buf))) (define (simple-motion-command buf k) (cond ((char=? k ^A) (move-to-pos0 buf) #t) ((char=? k ^B) (move-backward buf) #t) ((char=? k ^E) (move-to-eol buf) #t) ((char=? k ^F) (move-forward buf) #t) ((char=? k ^N) (move-down buf) #t) ((char=? k ^P) (move-up buf) #t) ((char=? k ^T) (move-prev-page buf) #t) ((char=? k ^V) (move-next-page buf) #t) ((char=? k ^W) (move-next-word buf) #t) ((char=? k ^X) (move-prev-word buf) #t) (else #f))) (define (motion-command buf k) (if (char=? k ^L) (begin (info " ^L Top Bottom Goto Locate Next") (l-motion-command buf (get-key buf))) (simple-motion-command buf k))) (define (save-pos buf) (list (buffer-x buf) (buffer-y buf) (buffer-top buf))) (define (reset-pos buf pos) (buffer-set-x! buf (car pos)) (buffer-set-y! buf (cadr pos)) (buffer-set-top! buf (caddr pos))) (define (restore-pos buf pos) (reset-pos buf pos) (update-col buf) (show-buffer buf)) ; ----- mark commands ----- (define (raise-mark buf) (buffer-set-mark! buf #f) (buffer-set-reg0! buf (list (buffer-x buf) (buffer-y buf)))) (define (finish-mark buf) (buffer-set-mark! buf #t)) (define (drop-mark buf) (let ((redraw (buffer-reg0 buf))) (buffer-set-mark! buf #f) (buffer-set-reg0! buf #f) (if redraw (show-buffer buf)))) (define (toggle-mark buf) (cond ((not (buffer-reg0 buf)) (raise-mark buf)) ((not (buffer-mark buf)) (finish-mark buf)) (else (drop-mark buf) (show-buffer buf)))) (define (match-left buf on-scr intr) (let match-left ((k (buf-cur-char buf)) (n 0)) (cond ((and intr (key-pressed?)) #f) ((and on-scr (not (on-screen? buf (buffer-x buf) (buffer-y buf)))) #f) ((not k) (if (top-of-buf? buf) #f (begin (move-backward buf) (match-left (buf-cur-char buf) n)))) ((or (char=? k RP) (char=? k RB)) (move-backward buf) (match-left (buf-cur-char buf) (+ 1 n))) ((or (char=? k LP) (char=? k LB)) (cond ((zero? n) (list (buffer-x buf) (buffer-y buf))) (else (move-backward buf) (match-left (buf-cur-char buf) (- n 1))))) ((top-of-buf? buf) #f) (else (move-backward buf) (match-left (buf-cur-char buf) n))))) (define (match-right buf on-scr intr) (move-forward buf) (let match-right ((k (buf-cur-char buf)) (n 0)) (cond ((and intr (key-pressed?)) #f) ((and on-scr (not (on-screen? buf (buffer-x buf) (buffer-y buf)))) #f) ((end-of-buf? buf) #f) ((not k) (move-forward buf) (match-right (buf-cur-char buf) n)) ((or (char=? k LP) (char=? k LB)) (move-forward buf) (match-right (buf-cur-char buf) (+ 1 n))) ((or (char=? k RP) (char=? k RB)) (cond ((zero? n) (if (not on-scr) (move-forward buf)) (list (buffer-x buf) (buffer-y buf))) (else (move-forward buf) (match-right (buf-cur-char buf) (- n 1))))) (else (move-forward buf) (match-right (buf-cur-char buf) n))))) (define (mark-expr buf) (let* ((here (save-pos buf)) (k (buf-cur-char buf)) (left (begin (if (and k (or (char=? k RP) (char=? k RB))) (move-backward buf)) (match-left buf #f #f))) (right (if left (match-right buf #f #f) #f))) (restore-pos buf here) (if right (begin (buffer-set-reg0! buf left) (buffer-set-regn! buf right) (buffer-set-mark! buf #t) (show-buffer buf))))) ; ----- undo/redo stack ----- (define (log-undo buf what args) (if (and (not (null? (buffer-undo buf))) (eq? (buffer-last-char buf) (buffer-undo buf))) (buffer-set-last-char buf #f)) (buffer-set-redo! buf '()) (buffer-set-undo! buf (cons (list what args) (buffer-undo buf)))) (define (uncut buf r0 rn lines) (apply move-to buf r0) (splice-region #f buf (car r0) (cadr r0) lines)) (define (unsplice buf x y lines) (move-to buf x y) (let ((r0 (list x y)) (rn (list (if (null? (cdr lines)) (+ x (string-length (car lines))) (string-length (last lines))) (+ y (- (length lines) 1))))) (cut-region #f buf r0 rn))) (define (recut buf r0 rn lines) (apply move-to buf r0) (cut-region #f buf r0 rn)) (define (resplice buf x y lines) (move-to buf x y) (splice-region #f buf x y lines)) (define (shift-to-redo buf) (buffer-set-redo! buf (cons (car (buffer-undo buf)) (buffer-redo buf))) (buffer-set-undo! buf (cdr (buffer-undo buf)))) (define (shift-to-undo buf) (buffer-set-undo! buf (cons (car (buffer-redo buf)) (buffer-undo buf))) (buffer-set-redo! buf (cdr (buffer-redo buf)))) (define (undo buf u) (cond ((eq? 'cut (car u)) (apply uncut buf (cadr u))) ((eq? 'splice (car u)) (apply unsplice buf (cadr u))) ((eq? 'group (car u)) (for-each (curry undo buf) (cadr u))))) (define (undo-cmd buf) (let ((u (buffer-undo buf))) (if (null? u) (err "nothing to undo") (begin (undo buf (car u)) (modified! buf) (shift-to-redo buf) (update-col buf) (show-buffer buf))))) (define (redo buf r) (cond ((null? r) (err "nothing to redo")) ((eq? 'cut (car r)) (apply recut buf (cadr r))) ((eq? 'splice (car r)) (apply resplice buf (cadr r))) ((eq? 'group (car r)) (for-each (curry redo buf) (reverse (cadr r)))))) (define (redo-cmd buf) (let ((r (buffer-redo buf))) (if (null? r) (err "nothing to redo") (begin (redo buf (car r)) (modified! buf) (shift-to-undo buf) (update-col buf) (show-buffer buf))))) (define (begin-undo-group buf) (set! *undo-mark* (buffer-undo buf))) (define (end-undo-group buf) (let loop ((b (buffer-undo buf)) (g '())) (cond ((eq? b *undo-mark*) (buffer-set-undo! buf *undo-mark*) (log-undo buf 'group (reverse! g))) (else (loop (cdr b) (cons (car b) g)))))) ; ----- yank/delete/insert commands ----- (define (writable? buf) (if (read-only? buf) (begin (err "buffer is read-only") #f) #t)) (define-syntax if-writable (syntax-rules () ((_ buf body ...) (if (writable? buf) (begin body ...))))) (define (copy-region buf r0 rn) (let ((res '())) (let yank-line ((y (cadr r0)) (r '())) (let* ((line (buf-line buf y)) (k (string-length line))) (cond ((= y (cadr r0) (cadr rn)) (set! res (cons (substring line (car r0) (car rn)) r))) ((= y (cadr r0)) (yank-line (+ 1 y) (cons (substring line (car r0) k) r))) ((= y (cadr rn)) (set! res (cons (substring line 0 (car rn)) r))) (else (yank-line (+ 1 y) (cons line r)))))) (reverse! res))) (define (yank-region buf) (set! *yanked* (apply copy-region buf (region buf))) (buffer-set-mark! buf #t)) ; slow version without VECTOR-COPY and VECTOR-APPEND (define (delete-lines buf y0 yn) (let* ((range (- yn y0)) (max (- (buffer-length buf) range))) (if (> max 100) (info "deleting...")) (let loop ((i y0)) (if (< i max) (begin (change-line! buf i (buf-line buf (+ i range))) (loop (+ 1 i))))) (buffer-set-length! buf (- (buffer-length buf) range)) (status-line buf))) (define (delete-lines buf y0 yn) (let* ((range (- yn y0)) (len (buffer-length buf)) (max (- (buffer-length buf) range)) (top (vector-copy (buffer-buf buf) 0 y0)) (bot (vector-copy (buffer-buf buf) yn len))) (buffer-set-buf! buf (vector-append top bot)) (buffer-set-length! buf (- (buffer-length buf) range)) (status-line buf))) (define (cut-region log buf r0 rn) (if log (log-undo buf 'cut (list r0 rn (copy-region buf r0 rn)))) (cond ((= (cadr r0) (cadr rn)) (let ((line (buf-line buf (cadr r0)))) (change-line! buf (cadr r0) (string-append (substring line 0 (car r0)) (substring line (car rn) (string-length line)))))) ((and (zero? (car r0)) (zero? (car rn))) (delete-lines buf (cadr r0) (cadr rn))) (else (let* ((lin0 (buf-line buf (cadr r0))) (linn (buf-line buf (cadr rn))) (k (string-length linn)) (new (string-append (substring lin0 0 (car r0)) (substring linn (car rn) k)))) (change-line! buf (cadr r0) new) (delete-lines buf (+ 1 (cadr r0)) (+ 1 (cadr rn)))))) (buffer-set-mark! buf #f) (buffer-set-reg0! buf #f)) (define (delete-region buf yank) (if-writable buf (modified! buf) (cond ((region? buf) (if yank (yank-region buf)) (apply move-to buf (region-start buf)) (apply cut-region #t buf (region buf))) (else (raise-mark buf) (move-forward buf) (sync-mark buf) (move-backward buf) (apply cut-region #t buf (region buf)))) (show-buffer buf))) (define (backspace buf) (if-writable buf (cond ((region? buf) (delete-region buf #t)) ((top-of-buf? buf) (bell)) (else (move-backward buf) (drop-mark buf) (delete-region buf #f))))) (define (kill-line buf) (if-writable buf (cond ((= (buffer-x buf) (buf-cur-length buf)) (buffer-set-x! buf 0) (update-col buf) (raise-mark buf) (move-down buf) (sync-mark buf)) (else (raise-mark buf) (move-to-eol buf) (sync-mark buf))) (delete-region buf #t) (update-col buf))) ; slow version without VECTOR-COPY and VECTOR-APPEND (define (insert-lines buf y range) (let* ((max (- (buffer-length buf) 1))) (if (> max 100) (info "inserting...")) (let move ((i max)) (if (>= i y) (begin (change-line! buf (+ i range) (buf-line buf i)) (move (- i 1))))) (let fill ((i (+ y range -1))) (if (>= i y) (begin (change-line! buf i "") (fill (- i 1))))) (status-line buf))) (define (insert-lines buf y range) (let* ((max (- (buffer-length buf) 1)) (len (buffer-length buf)) (top (vector-copy (buffer-buf buf) 0 y)) (bot (vector-copy (buffer-buf buf) y len)) (mid (make-vector range ""))) (buffer-set-buf! buf (vector-append top mid bot)) (buffer-set-length! buf (+ len range)) (status-line buf))) (define (splice-region log buf x y lines) (let* ((old (buf-line buf y)) (left (substring old 0 x)) (right (substring old x (string-length old)))) (if log (log-undo buf 'splice (list x y lines))) (if (null? (cdr lines)) (begin (change-line! buf y (string-append left (car lines) right)) (list (+ x (string-length (car lines))) y)) (begin (change-line! buf y (string-append left (car lines))) (insert-lines buf (+ 1 y) 1) (change-line! buf (+ 1 y) (string-append (last lines) right)) (insert-lines buf (+ 1 y) (- (length lines) 2)) (let copy ((i (+ 1 y)) (lines (cdr lines))) (if (not (null? (cdr lines))) (begin (change-line! buf i (car lines)) (copy (+ 1 i) (cdr lines))))) (list (string-length (last lines)) (+ y (length lines) -1)))))) (define (splice-region-here buf lines char-hint) (define (insert-subsequent? buf hint last args) (and (eq? hint last) (= (buffer-y buf) (cadr args)) (= (buffer-x buf) (+ (car args) (string-length (caaddr args)))))) (let* ((hint (buffer-last-char buf)) (ubuf (buffer-undo buf)) (last (if (null? ubuf) '() (car ubuf))) (args (if (null? ubuf) '() (cadr last)))) (cond ((and char-hint (insert-subsequent? buf hint last args)) (set-car! (caddr args) (string-append (caaddr args) (car lines))) (splice-region #f buf (buffer-x buf) (buffer-y buf) lines)) (else (let ((r (splice-region #t buf (buffer-x buf) (buffer-y buf) lines))) (if char-hint (buffer-set-last-char! buf (car (buffer-undo buf)))) r))))) (define (set-region-here buf regn) (raise-mark buf) (buffer-set-regn! buf regn) (buffer-set-mark! buf #t)) (define (insert-region buf) (if-writable buf (if (not *yanked*) (err "nothing to insert") (let ((regn (splice-region-here buf *yanked* #f))) (set-region-here buf regn) (modified! buf) (show-buffer buf))))) (define (insert-char buf k) (if-writable buf (drop-mark buf) (splice-region-here buf (list (string k)) #t) (move-forward buf) (modified! buf) (show-cur-line buf))) (define (split-line buf) (if-writable buf (let* ((n (if (property 'auto-indent) (min (indentation (buf-cur-line buf)) (buffer-x buf)) 0)) (ind (make-string n #\space))) (drop-mark buf) (splice-region-here buf (list "" ind) #f) (move-down buf) (buffer-set-x! buf n) (update-col buf) (modified! buf) (show-buffer buf)))) (define symbolic? (let ((special (string->list "+-.*/<=>!?:$%_&~^"))) (lambda (c) (or (char-alphabetic? c) (char-numeric? c) (and (memv c special) #t))))) (define (find-prefix s words) (let ((k (string-length s))) (let loop ((w words) (r '())) (cond ((null? w) (let ((lim (if (null? r) 0 (apply min (map string-length r))))) (let loop ((i k)) (cond ((>= i lim) (if (zero? lim) "" (substring (car r) 0 i))) ((let ((c* (map (lambda (x) (string-ref x i)) r))) (and (> (length c*) 1) (not (apply char-ci=? c*)))) (substring (car r) 0 i)) (else (loop (+ 1 i))))))) ((and (<= k (string-length (car w))) (string-ci=? (substring (car w) 0 k) s)) (loop (cdr w) (cons (car w) r))) (else (loop (cdr w) r)))))) (define (expand-tabs buf) (let* ((k (- 8 (remainder (buffer-x buf) 8))) (s (make-string k #\space))) (splice-region-here buf (list s) #f) (buffer-set-x! buf (+ k (buffer-x buf))) (update-col buf) (show-cur-line buf))) (define (auto-complete buf) (if-writable buf (let ((line (buf-cur-line buf))) (if (or (zero? (buffer-x buf)) (char=? #\space (string-ref line (- (buffer-x buf) 1)))) (expand-tabs buf) (let find ((x (- (buffer-x buf) 1))) (let ((c (string-ref line x))) (cond ((or (zero? x) (not (symbolic? c))) (let* ((x0 (if (symbolic? c) x (+ 1 x))) (s (substring line x0 (buffer-x buf))) (cs (find-prefix s *symbols*)) (y (buffer-y buf))) (if (not (string=? "" cs)) (begin (begin-undo-group buf) (cut-region #t buf (list x0 y) (list (buffer-x buf) y)) (splice-region #t buf x0 y (list cs)) (end-undo-group buf) (buffer-set-x! buf (+ x0 (string-length cs))) (show-cur-line buf))))) (else (find (- x 1)))))))))) ; ----- long commands ----- (define (adjust-display buf) (let ((show #f)) (cond ((buffer-reg0 buf) (sync-mark buf) (set! show #t))) (cond ((< (buffer-x buf) (buffer-off buf)) (buffer-set-off! buf (max 0 (- (buffer-x buf ) (- *offset-jump* 1)))) (set! show #t)) ((>= (buffer-x buf) (+ (buffer-off buf) (cols))) (buffer-set-off! buf (- (buffer-x buf) (- (cols) *offset-jump*))) (set! show #t)) ((< (buffer-y buf) (buffer-top buf)) (buffer-set-top! buf (buffer-y buf)) (set! show #t)) ((>= (buffer-y buf) (+ (buffer-top buf) (- (screen-lines) 1))) (buffer-set-top! buf (- (buffer-y buf) (- (screen-lines) 1))) (set! show #t))) (if show (show-buffer buf)))) (define (yesno buf) (let ((k (get-key buf))) (case k ((#\y #\Y) #t) (else #f)))) (define (cmd-quit buf) (if (buf-prop? buf 'scheme-repl) (auto-save-repl)) (cond ((and (modified? buf) (begin (err "buffer is modified, discard changes? (y/n)") (not (yesno buf))))) ((null? (cdr *buffers*)) 'quit) (else (cmd-rotate buf) (delete-buffer buf)))) (define (cmd-kill-session buf) (let ((n (modified-buffers))) (cond ((> n 1) (err "there are ~D modified buffers, really quit? (y/n)" n) (if (yesno buf) 'quit)) ((modified? buf) (err "buffer is modified, really quit? (y/n)") (if (yesno buf) 'quit)) ((positive? n) (err "there is a modified buffer, really quit? (y/n)") (if (yesno buf) 'quit)) (else 'quit)))) (define (cmd-exit buf) (cmd-save buf) (cmd-quit buf)) (define (cmd-redraw buf) (clear) (show-buffer buf) (status-line buf)) (define (fill-dir-buffer dir path) (move-to dir 0 0 0) (buffer-set-length! dir 0) (buffer-set-name! dir path) (let fill ((files (cons ".." (mergesort string<? (read-directory path)))) (pos 0)) (if (not (null? files)) (begin (change-line! dir pos (car files)) (fill (cdr files) (+ 1 pos)))))) (define (adjust-path path file) (if (string=? ".." file) (let* ((s* (string-split #\/ path)) (s (string-unsplit #\/ (reverse! (cdr (reverse s*)))))) (if (string=? "" s) "/" s)) (string-append path "/" file))) (define (mark-line buf) (buffer-set-x! buf 0) (raise-mark buf) (move-to-eol buf) (sync-mark buf) (buffer-set-mark! buf #t) (buffer-set-x! buf 0) (adjust-display buf)) (define (select-file buf path) (let ((dir (fresh-buffer '(read-only))) (path (if (string=? "." path) (getcwd) (string-append (getcwd) "/" path)))) (fill-dir-buffer dir path) (show-buffer dir) (status-line dir) (let select () (mark-line dir) (let ((k (get-key dir))) (cond ((motion-command dir k) (select)) ((or (char=? k ^C) (char=? k ^G) (char=? k #\q)) (delete-buffer dir) (show-buffer buf) #f) ((char=? k ^M) (let* ((file (buf-cur-line dir)) (new (string-append path "/" file))) (if (directory? new) (if (file-readable? new) (begin (set! path (adjust-path path file)) (fill-dir-buffer dir path) (select)) (begin (err "directory not readable") (select))) (begin (show-buffer buf) (delete-buffer dir) new)))) (else (info " ^LE q = quit ENTER = open") (select))))))) (define (cmd-edit buf) (cond ((or (not (modified? buf)) (begin (err "buffer is modified, discard changes? (y/n)") (yesno buf))) (color-info) (let* ((file (get-line (statline-pos) 0 "" "edit: ")) (file (if (string=? "" file) "." file))) (cond ((not file)) ((directory? file) (let ((file (select-file buf file))) (if file (begin (clear-buffer buf) (buf-rem-prop! buf 'read-only) (load-buffer buf file)) (info "never mind")))) (else (clear-buffer buf) (buf-rem-prop! buf 'read-only) (load-buffer buf file))))))) (define (get-name buf prompt) (let loop ((name "")) (color-info) (let ((name (get-line (statline-pos) 0 name prompt #t))) (cond ((or (not name) (string=? "" name)) #f) ((or (not (file-exists? name)) (begin (err "file already exists; overwrite? (y/n)") (yesno buf))) name) (else (loop name)))))) (define (cmd-save buf) (if-writable buf (let ((name (if (buffer-name buf) (buffer-name buf) (get-name buf "save: ")))) (if name (buffer-set-name! buf name)) (cond ((not name) (info "never mind") #f) ((and (file-exists? name) (not (file-writable? name))) (err "file not writable") #f) ((save-buffer buf (buffer-name buf)) (buf-rem-prop! buf 'modified) #t) (else #f))))) (define (cmd-sync buf) (let save ((b *buffers*) (n 0)) (cond ((null? b) (show-buffer buf) (info "~D buffer(s) saved" n)) ((or (buf-prop? (car b) 'read-only) (buf-prop? (car b) 'transient) (buf-prop? (car b) 'scheme-repl)) (save (cdr b) n)) ((modified? (car b)) (if (not (buffer-name (car b))) (show-buffer (car b))) (if (cmd-save (car b)) (save (cdr b) (+ 1 n)) (save (cdr b) n))) (else (save (cdr b) n))))) (define (cmd-save-as buf) (let ((name (get-name buf "save as: "))) (cond ((not name) (info "never mind")) ((and (file-exists? name)) (not (file-writable? name)) (err "file exists and is not writable")) ((or (not (file-exists? name)) (begin (err "file exists; overwrite? (y/n)") (yesno buf))) (save-buffer buf name))))) (define (cmd-write buf) (if (not (region? buf)) (err "no region marked for writing") (let ((name (get-name buf "write region: "))) (cond ((not name) (info "never mind")) ((and (file-exists? name) (not (file-writable? name))) (err "file not writable")) (else (save-buffer buf name (region-start buf) (region-end buf))))))) (define (cmd-read buf) (color-info) (let ((name (get-line (statline-pos) 0 "" "read file: "))) (cond ((or (not name) (string=? "" name)) (info "never mind")) ((not (file-exists? name)) (err "no such file")) ((not (file-readable? name)) (err "file not readable")) (else (let* ((lines (append (with-input-from-file name read-file) '(""))) (regn (splice-region-here buf lines #f))) (set-region-here buf regn) (modified! buf) (show-buffer buf)))))) (define (string-pos s1 s2) ((if (property 'sense-case) string-position string-ci-position) s1 s2)) (define (string-last-pos s1 s2) ((if (property 'sense-case) string-last-position string-ci-last-position) s1 s2)) (define (find-next buf text . options) (let ((offset (if (memq 'first options) 0 1))) (cond ((and (> (buf-cur-length buf) (buffer-x buf)) (string-pos text (substring (buf-cur-line buf) (+ offset (buffer-x buf)) (buf-cur-length buf)))) => (lambda (col) (buffer-set-x! buf (+ offset (buffer-x buf) col)) #t)) (else (info "searching...") (let loop ((y (+ 1 (buffer-y buf)))) (cond ((>= y (buffer-length buf)) (set! *message* #f) (err "string not found") #f) ((string-pos text (buf-line buf y)) => (lambda (col) (if (memq 'silent options) (go-to buf col y) (move-to buf col y)) #t)) (else (loop (+ 1 y))))))))) (define (find-previous buf text) (cond ((string-last-pos text (substring (buf-cur-line buf) 0 (buffer-x buf))) => (lambda (col) (buffer-set-x! buf col) #t)) (else (info "searching...") (let loop ((y (- (buffer-y buf) 1))) (cond ((negative? y) (set! *message* #f) (err "string not found") #f) ((string-last-pos text (buf-line buf y)) => (lambda (col) (move-to buf col y) #t)) (else (loop (- y 1)))))))) (define (cmd-locate buf) (color-info) (let ((text (get-line (statline-pos) 0 (buffer-searchstr buf) "locate: " #t))) (cond ((or (not text) (string=? "" text)) (info "never mind")) (else (buffer-set-searchstr! buf text) (let loop ((found (find-next buf text))) (if found (info " ^LL ^N = next ^P = previous other = exit")) (let ((k (get-key buf))) (cond ((char=? k ^N) (loop (find-next buf text))) ((char=? k ^P) (loop (find-previous buf text)))))))))) (define (cmd-next buf) (let ((sstr (buffer-searchstr buf))) (if (string=? "" sstr) (err "nothing to locate") (find-next buf sstr)))) (define (mark-cols buf cols) (raise-mark buf) (buffer-set-regn! buf (list (+ (buffer-x buf) cols) (buffer-y buf))) (buffer-set-mark! buf #t)) (define (exchange buf old new) (define (change new) (apply cut-region #t buf (region buf)) (splice-region-here buf (list new) #f) (modified! buf)) (move-to buf 0 0) (let ((cols (string-length old)) (auto #f) (first #t) (msg " ^LX CR = replace space = skip Q = quit A = all L = last") (n 0)) (begin-undo-group buf) (let loop () (if (not (find-next buf old (if auto 'silent '()) (if first 'first '()))) (end-undo-group buf) (begin (set! first #f) (mark-cols buf cols) (if (not auto) (begin (show-buffer buf) (info msg))) (let ((k (if auto ^M (get-key buf)))) (cond ((char=? k ^M) (change new) (inc! n) (loop)) ((char=? k #\space) (loop)) ((memv k '(#\Q #\q)) (end-undo-group buf)) ((memv k '(#\A #\a)) (change new) (inc! n) (set! auto #t) (loop)) ((memv k '(#\L #\l)) (change new) (inc! n) (end-undo-group buf))))))) (if auto (info "~D strings replaced" n)))) (define (auto-exchange buf old new reg0 regn) (define (change new) (let ((reg0 (buffer-reg0 buf)) (regn (buffer-regn buf))) (mark-cols buf (string-length old)) (apply cut-region #t buf (region buf)) (splice-region-here buf (list new) #f) (buffer-set-reg0! buf reg0) (buffer-set-regn! buf regn) (buffer-set-mark! buf #t) (modified! buf))) (buffer-set-mark! buf #t) (apply move-to buf reg0) (let ((here (save-pos buf)) (ocol (string-length old)) (ncol (string-length new)) (first #t) (n 0)) (begin-undo-group buf) (let loop () (if (and (find-next buf old 'silent (if first 'first '())) (apply before (buffer-x buf) (buffer-y buf) regn)) (begin (set! first #f) (change new) (set! here (save-pos buf)) (inc! n) (loop)))) (end-undo-group buf) (restore-pos buf here) (if (not (zero? n)) (info "~D strings replaced" n)))) (define (cmd-exchange buf) (if-writable buf (color-info) (let* ((sstr (buffer-searchstr buf)) (old (get-line (statline-pos) 0 sstr "old: " #t)) (new (if old (get-line (statline-pos) 0 "" "new: ") #f))) (cond ((or (not old) (not new) (string=? "" old)) (info "never mind")) ((region? buf) (apply auto-exchange buf old new (region buf))) (else (exchange buf old new))) (show-buffer buf)))) (define (region-of-lines! buf) (let* ((r (region buf)) (reg0 (car r)) (regn (cadr r))) (buffer-set-reg0! buf (list 0 (cadr reg0))) (if (positive? (car regn)) (buffer-set-regn! buf (list 0 (+ 1 (cadr regn))))) (show-buffer buf))) (define (in/out-dent-region buf action) (let* ((reg (region buf)) (text (apply copy-region buf reg))) (move-to buf 0 (cadr (region-start buf))) (apply cut-region #t buf reg) (let ((text (map action text))) (let ((r (splice-region-here buf text #f))) (set-region-here buf r) (show-buffer buf))))) (define (indent buf) (in/out-dent-region buf (lambda (s) (if (string=? "" s) s (string-append " " s))))) (define (outdentable? buf) (let outdent ((y (cadr (region-start buf)))) (if (>= y (cadr (region-end buf))) #t (let ((s (buf-line buf y))) (if (and (not (string=? "" s)) (not (char=? #\space (string-ref s 0)))) #f (outdent (+ 1 y))))))) (define (outdent buf) (if (not (outdentable? buf)) (begin (set! *message* #f) (err "insufficient leading space")) (in/out-dent-region buf (lambda (s) (if (string=? "" s) s (substring s 1 (string-length s))))))) (define (cmd-indent buf) (if-writable buf (let ((msg " ^LI ^B = outdent ^F = indent other = quit")) (cond ((not (region? buf)) (err "no region to indent")) (else (region-of-lines! buf) (buffer-set-mark! buf #t) (info msg) (begin-undo-group buf) (let loop () (info msg) (let ((k (get-key buf))) (cond ((char=? k ^F) (indent buf) (loop)) ((char=? k ^B) (outdent buf) (loop)) (else (if (not (eq? *undo-mark* (buffer-undo buf))) (begin (end-undo-group buf) (let* ((g (cadar (buffer-undo buf))) (u0 (car g)) (ul (last g))) (set-car! (buffer-undo buf) `(group (,u0 ,ul)))))) (status-line buf)))))))))) (define (run-filter buf cmd) (region-of-lines! buf) (let* ((filter (spawn-shell-command cmd)) (reg (region buf)) (text (apply copy-region buf reg))) (move-to buf 0 (cadr (region-start buf))) (info "filtering...") (begin-undo-group buf) (apply cut-region #t buf reg) (for-each (lambda (x) (display x (cadr filter)) (newline (cadr filter))) text) (close-output-port (cadr filter)) (let ((text (map string-expand (read-file (car filter))))) (let ((r (splice-region-here buf text #f))) (end-undo-group buf) (set-region-here buf r) (show-buffer buf))))) (define (cmd-filter buf) (if-writable buf (cond ((not (region? buf)) (err "no region to filter")) (else (color-info) (let ((cmd (get-line (statline-pos) 0 "" "filter: "))) (cond ((or (not cmd) (string=? "" cmd)) (info "never mind")) (else (run-filter buf cmd)))))))) (define (help-buffer) (find-buffer 'help-buffer #t)) (define (cmd-help buf) (let* ((hb (help-buffer)) (id (buffer-name hb))) (if (< (buffer-length hb) 2) (let ((helpfile (locate-file "s9e.help"))) (if (not helpfile) (err "oops - help file (s9e.help) not found!") (begin (load-buffer hb helpfile) (buffer-set-name! hb id) (buf-set-prop! hb 'read-only))))) (set! *switch-to* hb))) (define (cmd-buf-list buf) (let ((blist (fresh-buffer (list 'read-only 'transient)))) (buffer-set-name! blist "*buffer-list*") (do ((i 0 (+ 1 i)) (b *buffers* (cdr b))) ((null? b)) (let ((line (format #f "~C~C~C ~7:D ~A" (if (buf-prop? (car b) 'auto-load) #\a #\.) (if (modified? (car b)) #\m #\.) (if (read-only? (car b)) #\r #\.) (buffer-length (car b)) (if (buffer-name (car b)) (buffer-name (car b)) "*anonymous*")))) (change-line! blist i line))) (show-buffer blist) (status-line blist) (let loop () (mark-line blist) (let ((k (get-key blist))) (cond ((motion-command blist k) (loop)) ((or (char=? k ^C) (char=? k ^G) (char=? k #\q)) (delete-buffer blist) (show-buffer buf) #f) ((char=? k ^M) (let ((b (nth-buffer (buffer-y blist)))) (if (buf-prop? b 'transient) (err "buffer is transient") (set! *switch-to* (nth-buffer (buffer-y blist))))) (delete-buffer blist) (show-buffer buf)) (else (info " ^LV q = quit ENTER = select") (loop))))))) (define (cmd-buf-open buf) (set! *switch-to* (fresh-buffer '())) (status-line *switch-to*)) (define (cmd-rotate buf) (let ((this (this-buffer buf))) (if (null? (cdr this)) (set! *switch-to* (car *buffers*)) (set! *switch-to* (cadr this))) (status-line *switch-to*))) (define (parse-color dflt name) (let ((colors `((black . ,*black*) (blue . ,*blue*) (green . ,*green*) (cyan . ,*cyan*) (red . ,*red*) (magenta . ,*magenta*) (yellow . ,*yellow*) (gray . ,*gray*) (white . ,*gray*)))) (let* ((fg/bg (string-split #\/ name)) (fg (car fg/bg)) (bg (if (null? (cdr fg/bg)) "" (cadr fg/bg))) (fg (assq (string->symbol fg) colors)) (bg (assq (string->symbol bg) colors))) (if (and fg bg) (list (cdr fg) (cdr bg)) dflt)))) (define (parse-setprop-cmd buf s err-fn) (define (find-prop s) (let find ((p *properties*)) (cond ((null? p) #f) ((string=? s (prop-abbr (car p))) (car p)) ((string=? s (symbol->string (prop-prop (car p)))) (car p)) (else (find (cdr p)))))) (define (set-prop-value buf p v) (let ((v (if (number? (prop-default p)) (let ((n (string->number v))) (if n n (begin (err-fn "~A: numeric value expected" (prop-prop p)) (prop-default p)))) v))) (if (eq? 'global (prop-scope p)) (put-prop! *globals* (prop-prop p) v) (buffer-set-properties! buf (put-prop (buffer-properties buf) (prop-prop p) v))) (update-colors))) (let* ((s (string-skip-white s)) (k (string-length s)) (v (string-position "=" s))) (cond ((or (string-prefix=? "no-" s) (string-prefix=? "no" s)) (let* ((s (if (string-prefix=? "no-" s) (substring s 3 k) (substring s 2 k))) (p (find-prop s))) (if p (set-prop-value buf p #f) (err-fn "no such property: ~A" s)))) (v (let ((s (substring s 0 v)) (v (substring s (+ 1 v) k))) (let ((p (find-prop s))) (if p (set-prop-value buf p v) (err-fn "no such property: ~A" s))))) (else (let ((p (find-prop s))) (if p (set-prop-value buf p #t) (err-fn "no such property: ~A" s))))))) (define (edit-setprop-cmd buf s) (color-info) (let ((s (get-line (statline-pos) 0 s "property: " #t))) (cond ((or (not s) (string=? "" s)) (info "never mind")) (else (parse-setprop-cmd buf s err))))) (define (list-properties buf) (define (prop-value p) (if (eq? 'global (prop-scope p)) (get-prop *globals* (prop-prop p)) (get-prop (buffer-properties buf) (prop-prop p)))) (define (prop->string p) (let* ((name (format #f "~15A" (prop-prop p))) (val (prop-value p)) (val (cond ((boolean? val) (if val "on" "off")) ((number? val) (number->string val)) (else (string-append "\"" val "\"")))) (line (string-append (prop-abbr p) " " name val))) (if (eq? 'local (prop-scope p)) (string-append line " (local)") line))) (define (make-config-cmd p) (let ((v (prop-value p))) (cond ((eq? v #t) (prop-abbr p)) ((eq? v #f) (string-append "no" (prop-abbr p))) ((number? v) (string-append (prop-abbr p) "=" (number->string v))) (else (string-append (prop-abbr p) "=" v))))) (let ((plist (fresh-buffer (list 'read-only 'transient)))) (buffer-set-name! plist "*property-list*") (let reload () (buffer-set-length! plist 1) (do ((i 0 (+ 1 i)) (p *properties* (cdr p))) ((null? p)) (if (not (eq? 'internal (prop-scope (car p)))) (change-line! plist i (prop->string (car p))))) (show-buffer plist) (if (not *message*) (status-line plist)) (let loop () (mark-line plist) (let ((k (get-key plist))) (cond ((motion-command plist k) (loop)) ((or (char=? k ^C) (char=? k ^G) (char=? k #\q)) (delete-buffer plist) (show-buffer buf)) ((char=? k ^M) (edit-setprop-cmd buf (make-config-cmd (list-ref *properties* (buffer-y plist)))) (reload)) (else (info " ^LP q = quit ENTER = change") (loop)))))))) (define (cmd-set-props buf) (color-info) (let ((prop (get-line (statline-pos) 0 "" "property: "))) (cond ((not prop) (info "never mind")) ((string=? "" prop) (list-properties buf)) (else (parse-setprop-cmd buf prop err))))) (define (l-motion-command buf k) (cond ((char=? k ^V) (move-to-eof buf) #t) ((char=? k ^L) (cmd-redraw buf) #t) ((char=? k ^T) (move-to buf 0 0 0) #t) ((char=? k #\b) (move-to-eof buf) #t) ((char=? k #\g) (move-to-line buf) #t) ((char=? k #\l) (cmd-locate buf) #t) ((char=? k #\n) (cmd-next buf) #t) ((char=? k #\t) (move-to buf 0 0 0) #t) (else #f))) (define (l-command buf) (let* ((msgs #(" ^L Top Bottom Locate Next eXchange Goto Help Quit" " ^L Edit Read Save saveAs Write sYnc Indent Filter " " ^L Kill-buffers Open-buffer View-buffers ")) (nmsg (vector-length msgs))) (let loop ((n 0)) (info (string-append (vector-ref msgs n) " space=more")) (let ((k (get-key buf))) (cond ((not k)) ((l-motion-command buf k)) ((char=? k #\a) (cmd-save-as buf)) ((char=? k #\e) (cmd-edit buf)) ((char=? k #\f) (cmd-filter buf)) ((char=? k #\h) (cmd-help buf)) ((char=? k #\i) (cmd-indent buf)) ((char=? k #\k) (cmd-kill-session buf)) ((char=? k #\o) (cmd-buf-open buf)) ((char=? k #\p) (cmd-set-props buf)) ((char=? k #\q) (cmd-quit buf)) ((char=? k #\r) (cmd-read buf)) ((char=? k #\s) (cmd-save buf)) ((char=? k #\v) (cmd-buf-list buf)) ((char=? k #\w) (cmd-write buf)) ((char=? k #\x) (cmd-exchange buf)) ((char=? k #\y) (cmd-sync buf)) ((char=? k #\z) (cmd-exit buf)) ((char=? k #\space) (loop (if (= n (- nmsg 1)) 0 (+ 1 n)))) (else)))))) ; ----- Scheme commands ----- (define (run-scheme) (let* ((scm (string-parse (string #\space) (property 'repl-command))) (path (getenv "PATH")) (cmd (if (char=? #\. (string-ref (car scm) 0)) (car scm) (search-path (car scm) (if path path "")))) (cmd (if cmd cmd (car scm))) (args (cdr scm))) (let ((conn (spawn-command/fd cmd args))) (set! *repl* (list (car conn) (make-output-port (cadr conn)) (caddr conn)))))) (define (send-to-repl s*) (catch-errors #t) (for-each (lambda (s) (display s (cadr *repl*)) (newline (cadr *repl*))) s*) (catch-errors #f)) (define (flush-repl) (let ((done-magic (string-append "(done " (number->string (unix-time)) ")"))) (send-to-repl (list (string-append (string #\newline) "(newline)" (string #\newline) "'" done-magic))) (catch-errors #t) (flush-output-port (cadr *repl*)) (catch-errors #f) done-magic)) (define (make-reader input-fd) (let ((buffer #f) (limit 0) (next 0)) (lambda chars-left? (cond ((not (null? chars-left?)) (< next limit)) ((>= next limit) (let* ((next-buffer (fd-read input-fd 10240)) (k (string-length next-buffer))) (if (zero? k) #f (begin (set! buffer next-buffer) (set! limit k) (set! next 1) (string-ref buffer 0))))) (else (let ((c (string-ref buffer next))) (set! next (+ 1 next)) c)))))) (define (read-line-from-repl reader) (letrec ((collect-chars (lambda (c s) (cond ((not c) (if (null? s) c (string-expand (list->string (reverse! s))))) ((char=? c #\newline) (string-expand (list->string (reverse! s)))) (else (collect-chars (reader) (cons c s))))))) (collect-chars (reader) '()))) (define (user-interrupt?) (nodelay #t) (let ((k (getch))) (nodelay #f) (eqv? 3 k))) (define (disconnect!) (close-output-port (cadr *repl*)) (catch-errors #t) (send-signal (caddr *repl*)) (wait-for-process) (catch-errors #f) (set! *repl* #f)) (define (hello-scheme?) (let* ((magic (flush-repl)) (k (string-length magic)) (reader (make-reader (car *repl*)))) (let ((s (begin (read-line-from-repl reader) (read-line-from-repl reader)))) (and (string? s) (>= (string-length s) k) (string=? magic (substring s 0 k)))))) (define (start-scheme-repl) (if (not *repl*) (begin (catch-errors #t) (run-scheme) (let ((e (errno))) (catch-errors #f) (cond ((not *repl*) (disconnect!) (err "failed to run scheme: ~A" (errno->string e))) ((hello-scheme?) (send-to-repl (list (property 'repl-init))) (get-repl-output #f (property 'repl-timeout) #f #t)) (else (disconnect!) (err "failed to run scheme (no response)"))))))) (define (append-to-buffer dest lines) (modified! dest) (if (not (string=? "" (buf-line dest (- (buffer-length dest) 1)))) (change-line! dest (buffer-length dest) "")) (go-to dest 0 (- (buffer-length dest) 1) (screen-lines)) (let ((regn (splice-region-here dest (append lines '("")) #f))) (raise-mark dest) (buffer-set-mark! dest #t) (buffer-set-regn! dest regn))) (define (get-repl-output dest timeout skip-comments silent) (let ((done-magic (flush-repl)) (reader (make-reader (car *repl*)))) (info "running...") (set! *message* #f) (let loop ((output '())) (cond ((and (not (reader 'check)) (not (fd-select (list timeout 0) (list (car *repl*)) '()))) (disconnect!) (err "run time limit exceeded")) ((user-interrupt?) (disconnect!) (err "interrupted")) (else (let ((s (read-line-from-repl reader))) (cond ((not s) (if dest (append-to-buffer dest (reverse! output))) (disconnect!) (err "error(s) found")) ((string=? done-magic s) (let ((output (if (and (not (null? output)) (string=? "" (car output))) (reverse! (cdr output)) (reverse! output)))) (if dest (append-to-buffer dest output)) (if (and (not silent) (positive? (length output))) (info "output received")))) ((and skip-comments (> (string-length s) 1) (char=? #\; (string-ref s 0))) (loop output)) (else (loop (cons s output)))))))))) (define (load-repl-buffer sb) (and-let* ((home (getenv "HOME")) (path (string-append home "/.s9fes/s9e-repl-buffer")) (_ (file-readable? path))) (load-buffer sb path 'silent) (go-to sb 0 (- (buffer-length sb) 1) (screen-lines)))) (define (scheme-buffer) (let ((sb (find-buffer 'scheme-repl))) (if (not sb) (let ((sb (find-buffer 'scheme-repl #t))) (load-repl-buffer sb) sb) sb))) (define (scheme-repl buf) (start-scheme-repl) (set! *switch-to* (scheme-buffer))) (define (compile-buffer buf) (start-scheme-repl) (let ((k (buffer-length buf))) (do ((i 0 (+ 1 i))) ((>= i k)) (display (buf-line buf i) (cadr *repl*)) (newline (cadr *repl*)))) (get-repl-output (scheme-buffer) (property 'load-timeout) #t #t)) (define (scheme-compile buf) (compile-buffer buf) (if (not *message*) (info "buffer compiled"))) (define (auto-load buf) (do ((b *buffers* (cdr b))) ((or (null? b) *message*)) (if (buf-prop? (car b) 'auto-load) (compile-buffer (car b))))) (define (scheme-eval buf) (let ((here (save-pos buf))) (start-scheme-repl) (auto-load buf) (if (not *message*) (begin (restore-pos buf here) (mark-expr buf) (if (not (region? buf)) (err "nothing to evaluate") (let ((prog (apply copy-region buf (region buf)))) (send-to-repl prog) (get-repl-output (scheme-buffer) (property 'repl-timeout) #f #f))))))) (define (scheme-pretty-print buf . options) (if-writable buf (if (not (region? buf)) (err "nothing to pretty-print") (let* ((reg (region buf)) (text (apply copy-region buf reg))) (modified! buf) (apply move-to buf (buffer-reg0 buf)) (begin-undo-group buf) (apply cut-region #t buf reg) (let* ((text (apply pp-string text 'indent: (buffer-x buf) options)) (r (splice-region-here buf text #f))) (end-undo-group buf) (set-region-here buf r) (show-buffer buf)))))) (define (z-command buf) (info " ^Z Compile Eval Format Pretty-print Scheme ^Z = mark expr") (let ((k (get-key buf))) (cond ((char=? k ^Z) (mark-expr buf)) ((char=? k #\c) (scheme-compile buf)) ((char=? k #\e) (scheme-eval buf)) ((char=? k #\f) (scheme-pretty-print buf 'data)) ((char=? k #\p) (scheme-pretty-print buf 'code)) ((char=? k #\s) (scheme-repl buf)) (else #f)))) ; ----- command loop ----- (define (paren-match buf on) (let ((c (buf-cur-char buf)) (x (buffer-col buf)) (h (save-pos buf)) (d #f)) (cond ((not c)) ((and (char=? c LP) (match-right buf #t on)) (sync-pos buf) (if on (color-paren) (color-text)) (addch RP) (set! d #t)) ((and (char=? c RP) (begin (move-backward buf) (match-left buf #t on))) (sync-pos buf) (if on (color-paren) (color-text)) (addch LP) (set! d #t)) ((and (char=? c LB) (match-right buf #t on)) (sync-pos buf) (if on (color-paren) (color-text)) (addch RB) (set! d #t)) ((and (char=? c RB) (begin (move-backward buf) (match-left buf #t on))) (sync-pos buf) (if on (color-paren) (color-text)) (addch LB) (set! d #t))) (reset-pos buf h) (buffer-set-col! buf x) d)) (define (command-loop buf) (let/cc exit (let ((pmatch #f)) (let loop () (if *switch-to* (begin (set! buf *switch-to*) (set! *switch-to* #f) (show-buffer buf))) (if (not *message*) (status-line buf)) (adjust-display buf) (if (property 'show-match) (set! pmatch (paren-match buf #t)) (set! pmatch #f)) (let ((k (get-key buf))) (if pmatch (paren-match buf #f)) (cond ((not k)) ((simple-motion-command buf k)) ((char=? k ^D) (delete-region buf #t)) ((char=? k ^H) (backspace buf)) ((char=? k ^I) (auto-complete buf)) ((char=? k ^J) (scheme-eval buf)) ((char=? k ^K) (kill-line buf)) ((char=? k ^L) (if (eq? 'quit (l-command buf)) (exit #t))) ((char=? k ^M) (split-line buf)) ((char=? k ^O) (yank-region buf)) ((char=? k ^Q) (cmd-rotate buf)) ((char=? k ^R) (redo-cmd buf)) ((char=? k ^S) (toggle-mark buf)) ((char=? k ^U) (undo-cmd buf)) ((char=? k ^Y) (insert-region buf)) ((char=? k ^Z) (z-command buf)) ((<= 32 (char->integer k) 126) (insert-char buf k)) (else (err "unknown command: ~A; press ^L-h for help" (visual-char k)))) (loop)))))) ; ----- init and shutdown ----- (define (init) (initscr) (raw) (noecho) (nonl) (idlok #t) (scrollok #f) (keypad #t) (set! *spaces* (make-string (cols) #\space)) (set! *dashes* (make-string (cols) #\-))) (define (quit) (color-text) (mvaddstr (statline-pos) 0 *spaces*) (refresh) (move (statline-pos) 0) (endwin)) (define (auto-save-repl) (let ((sb (scheme-buffer))) (cond ((buf-prop? sb 'modified) (if (not (save-buffer sb (buffer-name sb))) (begin (err "Could not save REPL buffer! (This is a bug!)") (getch))))))) (define (set-up-defaults) (for-each (lambda (p) (if (eq? 'global (prop-scope p)) (put-prop! *globals* (prop-prop p) (prop-default p)))) *properties*)) (define (load-config buf) (and-let* ((home (getenv "HOME")) (path (string-append home "/.s9fes/s9e-config")) (_ (file-readable? path))) (with-input-from-file path (lambda () (let ((errors #f)) (let read ((line (read-line))) (if (not (eof-object? line)) (cond ((or (zero? (string-length line)) (char=? #\# (string-ref line 0)))) (else (parse-setprop-cmd buf line (lambda x (display (apply format #f x)) (newline) (set! errors #t))) (read (read-line)))))) (if errors (exit 1))))))) (define (load-symbols) (and-let* ((home (getenv "HOME")) (path (string-append home "/.s9fes/symbols")) (_ (file-readable? path))) (set! *symbols* (with-input-from-file path read-file)))) (define (configure buf) (set-up-defaults) (load-config buf) (load-symbols)) (define (s9e . args) (let* ((file (if (null? args) #f (car args))) (options (if (null? args) '() (cdr args)))) (let ((buf (fresh-buffer (append options '(auto-load))))) (configure buf) (init) (show-buffer buf) (if file (load-buffer buf file) (info "Welcome to S9E beta! Press ^L-h for help.")) (menu-dashes) (show-buffer buf) (command-loop buf) (auto-save-repl) (quit))))