From fe7185b321ec80f2f8712895298eb2222c48d68c Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 23 Dec 2014 11:09:22 -0500 Subject: [PATCH] More progress --- rmacs/buffer.rkt | 60 ++++++++++++++--------- rmacs/display.rkt | 9 +++- rmacs/editor.rkt | 99 +++++++++++++++++++++++++------------- rmacs/keys.rkt | 3 +- rmacs/main.rkt | 5 +- rmacs/mode.rkt | 2 - rmacs/mode/fundamental.rkt | 41 ++++++++-------- rmacs/render.rkt | 38 +++++++++++++-- 8 files changed, 171 insertions(+), 86 deletions(-) diff --git a/rmacs/buffer.rkt b/rmacs/buffer.rkt index 91eb6a6..ab00a41 100644 --- a/rmacs/buffer.rkt +++ b/rmacs/buffer.rkt @@ -6,6 +6,7 @@ make-buffer register-buffer! lookup-buffer + unused-buffer-title file->buffer buffer-rename! buffer-reorder! @@ -16,6 +17,7 @@ buffer-group buffer-modeset buffer-column + buffer-apply-modeset! buffer-add-mode! buffer-remove-mode! buffer-toggle-mode! @@ -33,6 +35,7 @@ buffer-region buffer-region-update! buffer-insert! + buffer-replace-contents! call-with-excursion buffer-search buffer-findf) @@ -61,10 +64,17 @@ (define (make-buffergroup) (buffergroup circular-empty)) +(define (initial-contents-rope initial-contents) + (cond + [(string? initial-contents) (string->rope initial-contents)] + [(rope? initial-contents) initial-contents] + [(procedure? initial-contents) (initial-contents-rope (initial-contents))] + [else (error 'initial-contents-rope "Invalid initial-contents: ~v" initial-contents)])) + (define (make-buffer group ;; (Option BufferGroup) title ;; String #:initial-contents [initial-contents ""]) - (register-buffer! group (buffer (string->rope initial-contents) + (register-buffer! group (buffer (initial-contents-rope initial-contents) 0 title #f @@ -98,36 +108,36 @@ (define (title-exists-in-group? group title) (and (title->buffer* group title) #t)) +(define (unused-buffer-title group context-pieces) + (define primary-piece (if (null? context-pieces) "*anonymous*" (car context-pieces))) + (define uniquifiers (if (null? context-pieces) '() (cdr context-pieces))) + (let search ((used '()) (remaining uniquifiers)) + (define candidate + (if (null? used) + primary-piece + (format "~a<~a>" primary-piece (string-join used "/")))) + (if (title-exists-in-group? group candidate) + (if (pair? remaining) + (search (cons (car remaining) used) (cdr remaining)) + (let search ((counter 2)) + (define candidate (format "~a<~a>" primary-piece counter)) + (if (title-exists-in-group? group candidate) + (search (+ counter 1)) + candidate))) + candidate))) + ;; (Option Group) Path -> String (define (filename->unique-buffer-title group filename) (define pieces (reverse (map path->string (explode-path filename)))) - (define primary-piece (car pieces)) - (define uniquifiers (cdr pieces)) (if (not group) - primary-piece - (let search ((used '()) (remaining uniquifiers)) - (define candidate - (if (null? used) - primary-piece - (format "~a<~a>" primary-piece (string-join used "/")))) - (if (title-exists-in-group? group candidate) - (if (pair? remaining) - (search (cons (car remaining) used) (cdr remaining)) - (let search ((counter 2)) - (define candidate (format "~a<~a>" primary-piece counter)) - (if (title-exists-in-group? group candidate) - (search (+ counter 1)) - candidate))) - candidate)))) + (car pieces) + (unused-buffer-title group pieces))) (define (file->buffer group filename) (let* ((filename (normalize-path (simplify-path filename))) (title (filename->unique-buffer-title group filename)) (b (make-buffer group title))) - (buffer-region-update! b - (lambda (_dontcare) (string->rope (file->string filename))) - #:point 0 - #:mark (buffer-size b)) + (buffer-replace-contents! b (string->rope (file->string filename))) (buffer-move-to! b 0))) (define (buffer-rename! b new-title) @@ -153,6 +163,9 @@ (define (buffer-column buf) (- (buffer-pos buf) (buffer-start-of-line buf))) +(define (buffer-apply-modeset! buf modeset) + (set-buffer-modeset! buf modeset)) + (define (buffer-add-mode! buf mode) (set-buffer-modeset! buf (modeset-add-mode (buffer-modeset buf) mode))) (define (buffer-remove-mode! buf mode) @@ -238,6 +251,9 @@ (set-buffer-pos! buf (+ (buffer-pos buf) (rope-size content-rope)))) buf) +(define (buffer-replace-contents! buf content-rope) + (buffer-region-update! buf (lambda (_dontcare) content-rope) #:point 0 #:mark (buffer-size buf))) + (define (call-with-excursion buf f) (define excursion (gensym 'excursion)) (define saved-mark-type (mark-type (format "Saved mark ~a" excursion) 'right)) diff --git a/rmacs/display.rkt b/rmacs/display.rkt index c6eb468..3ac4a21 100644 --- a/rmacs/display.rkt +++ b/rmacs/display.rkt @@ -25,6 +25,7 @@ color-cyan color-white) +(require racket/set) (require racket/match) (require ansi) @@ -140,7 +141,13 @@ tty) (define (tty-next-key tty) - (lex-lcd-input (tty-input tty))) + (define k (lex-lcd-input (tty-input tty))) + (if (equal? k (key #\[ (set 'control))) ;; ESC + (or (sync/timeout 0.5 + (handle-evt (tty-next-key-evt tty) + (lambda (k) (add-modifier 'meta k)))) + k) + k)) (define (tty-next-key-evt tty) (handle-evt (tty-input tty) diff --git a/rmacs/editor.rkt b/rmacs/editor.rkt index a935ce9..7f19e3a 100644 --- a/rmacs/editor.rkt +++ b/rmacs/editor.rkt @@ -4,8 +4,8 @@ make-editor visit-file! render-editor! - current-editor-buffer - current-editor-modeset + editor-active-buffer + editor-active-modeset editor-invoke-command editor-mainloop editor-request-shutdown! @@ -19,89 +19,122 @@ (require "render.rkt") (require "mode.rkt") (require "keys.rkt") +(require "rope.rkt") (struct editor (buffers ;; BufferGroup [tty #:mutable] ;; Tty [windows #:mutable] ;; (List (List Window SizeSpec)), abstract window layout [active-window #:mutable] ;; (Option Window) [running? #:mutable] ;; Boolean + [default-modeset #:mutable] ;; ModeSet ) #:prefab) -(define (make-editor [tty (stdin-tty)]) +(define (make-editor #:tty [tty (stdin-tty)] + #:default-modeset [default-modeset (make-modeset)]) (define g (make-buffergroup)) (define scratch (make-buffer g "*scratch*" #:initial-contents ";; This is the scratch buffer.")) (define w (make-window scratch)) - (editor g - tty - (list (list w (relative-size 1))) - w - #f)) + (define e (editor g + tty + (list (list w (relative-size 1))) + w + #f + default-modeset)) + (configure-fresh-buffer! e scratch) + e) + +(define (configure-fresh-buffer! editor buffer) + (buffer-apply-modeset! buffer (editor-default-modeset editor)) + buffer) + +(define (find-buffer editor [title0 #f] #:initial-contents [initial-contents ""]) + (define g (editor-buffers editor)) + (define title (or title0 (unused-buffer-title g '()))) + (or (lookup-buffer g title) + (configure-fresh-buffer! editor (make-buffer g title #:initial-contents initial-contents)))) + +(define (open-window editor buffer + #:size [size (relative-size 1)] + #:activate? [activate? #t]) + (define w (make-window buffer)) + (set-editor-windows! editor (append (editor-windows editor) (list (list w size)))) + (when activate? (set-editor-active-window! editor w)) + w) (define (visit-file! editor filename) (set-window-buffer! (editor-active-window editor) - (file->buffer (editor-buffers editor) - filename))) + (configure-fresh-buffer! editor + (file->buffer (editor-buffers editor) filename)))) (define (render-editor! editor) (render-windows! (editor-tty editor) (editor-windows editor) (editor-active-window editor))) -(define (current-editor-buffer editor) +(define (editor-active-buffer editor) (define w (editor-active-window editor)) (and w (window-buffer w))) -(define (current-editor-modeset editor) - (define b (current-editor-buffer editor)) +(define (editor-active-modeset editor) + (define b (editor-active-buffer editor)) (and b (buffer-modeset b))) (define (root-keyseq-handler editor) - (modeset-keyseq-handler (current-editor-modeset editor))) + (modeset-keyseq-handler (editor-active-modeset editor))) (define (editor-invoke-command selector editor #:keyseq [keyseq #f] #:prefix-arg [prefix-arg '#:default]) - (define cmd (modeset-lookup-command (current-editor-modeset editor) selector)) + (define cmd (modeset-lookup-command (editor-active-modeset editor) selector)) (when (not cmd) - (error 'main "Unhandled command ~a (key sequence: ~a)" + (error 'editor-invoke-command "Unhandled command ~a (key sequence: ~a)" selector (keyseq->keyspec keyseq))) (cmd editor prefix-arg keyseq)) +(define (open-debugger editor exc) + (local-require (only-in web-server/private/util exn->string)) + (define error-report (exn->string exc)) + (log-error "Exception:\n~a\n" error-report) + (define b (find-buffer editor "*Error*")) + (buffer-replace-contents! b (string->rope error-report)) + (open-window editor b)) + (define (editor-mainloop editor) (when (editor-running? editor) (error 'editor-mainloop "Nested mainloop")) (set-editor-running?! editor #t) - (with-handlers ([exn? (lambda (e) - ;; TODO: proper error reporting - (local-require ansi) - (tty-restore!) - (raise e))]) - (let loop ((keys '()) + (with-handlers* ([exn? (lambda (exc) + (set-editor-running?! editor #f) + (open-debugger editor exc) + (editor-mainloop editor))]) + (let loop ((total-keyseq '()) + (input '()) (handler (root-keyseq-handler editor))) (define (wait-for-input next-handler) (render-editor! editor) (when (editor-running? editor) (sync (handle-evt (tty-next-key-evt (editor-tty editor)) (lambda (new-key) - (loop (list new-key) next-handler)))))) - (if (null? keys) + (define new-input (list new-key)) + (loop (append total-keyseq new-input) new-input next-handler)))))) + (if (null? input) (wait-for-input handler) - (match (handler editor keys) + (match (handler editor input) [(unbound-key-sequence) - (editor-invoke-command 'unbound-key-sequence editor #:keyseq keys) - (loop '() (root-keyseq-handler editor))] + (if (editor-invoke-command 'unbound-key-sequence editor #:keyseq total-keyseq) + (loop '() '() (root-keyseq-handler editor)) + (error 'editor-mainloop "Unbound key sequence: ~a" + (keyseq->keyspec total-keyseq)))] [(incomplete-key-sequence next-handler) (wait-for-input next-handler)] - [(key-macro-expansion new-keys) - (loop new-keys (root-keyseq-handler editor))] [(command-invocation selector prefix-arg remaining-input) (define accepted-input - (let loop ((input keys)) - (if (equal? input remaining-input) + (let remove-tail ((keyseq total-keyseq)) + (if (equal? keyseq remaining-input) '() - (cons (car input) (loop (cdr input)))))) + (cons (car keyseq) (remove-tail (cdr keyseq)))))) (editor-invoke-command selector editor #:keyseq accepted-input #:prefix-arg prefix-arg) - (loop remaining-input (root-keyseq-handler editor))]))))) + (loop '() remaining-input (root-keyseq-handler editor))]))))) (define (editor-request-shutdown! editor) (set-editor-running?! editor #f)) diff --git a/rmacs/keys.rkt b/rmacs/keys.rkt index a1cb5b9..3ffd691 100644 --- a/rmacs/keys.rkt +++ b/rmacs/keys.rkt @@ -107,7 +107,8 @@ (values "ESC" (set-remove modifiers 'control))] [(? char? c) (define s (format "~v" c)) - (values (substring s 2 (string-length s)) modifiers)])) + (define maybe-downcase (if (set-member? modifiers 'control) string-downcase values)) + (values (maybe-downcase (substring s 2 (string-length s))) modifiers)])) (format-modifiers updated-modifiers str)])) (define (keyseq->keyspec keyseq) diff --git a/rmacs/main.rkt b/rmacs/main.rkt index a9dfc0b..527f7bb 100644 --- a/rmacs/main.rkt +++ b/rmacs/main.rkt @@ -4,13 +4,14 @@ (require "editor.rkt") (require "buffer.rkt") +(require "mode.rkt") (require "mode/fundamental.rkt") (define (main) - (define e (make-editor)) + (define e (make-editor #:default-modeset (modeset-add-mode kernel-modeset + fundamental-mode))) (visit-file! e (build-path (collection-file-path "main.rkt" "rmacs") 'up 'up "doc" "xterm_controls.txt")) - (buffer-add-mode! (current-editor-buffer e) fundamental-mode) (editor-mainloop e)) (module+ main diff --git a/rmacs/mode.rkt b/rmacs/mode.rkt index 1ae021e..bf77f8c 100644 --- a/rmacs/mode.rkt +++ b/rmacs/mode.rkt @@ -5,7 +5,6 @@ (struct-out modeset) (struct-out incomplete-key-sequence) (struct-out unbound-key-sequence) - (struct-out key-macro-expansion) (struct-out command-invocation) make-raw-mode @@ -57,7 +56,6 @@ (struct incomplete-key-sequence (handler) #:prefab) (struct unbound-key-sequence () #:prefab) -(struct key-macro-expansion (keys) #:prefab) (struct command-invocation (selector prefix-arg remaining-input) #:prefab) (define (make-raw-mode name) diff --git a/rmacs/mode/fundamental.rkt b/rmacs/mode/fundamental.rkt index acc76b1..abd090c 100644 --- a/rmacs/mode/fundamental.rkt +++ b/rmacs/mode/fundamental.rkt @@ -2,6 +2,8 @@ (provide fundamental-mode) +(require racket/set) +(require racket/match) (require ansi/lcd-terminal) (require "../mode.rkt") (require "../editor.rkt") @@ -11,15 +13,12 @@ (define fundamental-mode (make-mode "fundamental")) -(void (mode-keymap-bind! fundamental-mode - "ESC" - (lambda (e ks) - (key-macro-expansion (cons (add-modifier 'meta (car ks)) (cdr ks)))))) - (define-command fundamental-mode (self-insert-command e #:keyseq keyseq) - (define ch (key-value (car (reverse keyseq)))) - (when (char? ch) - (buffer-insert! (current-editor-buffer e) (string->rope (string ch))))) + (log-info "self-insert-command ~a" (keyseq->keyspec keyseq)) + (match keyseq + [(list (key (? char? ch) modifiers)) #:when (set-empty? (set-remove modifiers 'shift)) + (buffer-insert! (editor-active-buffer e) (string->rope (string ch)))] + [_ #f])) (define-command fundamental-mode (unbound-key-sequence e #:keyseq keyseq) (editor-invoke-command 'self-insert-command e #:keyseq keyseq)) @@ -29,7 +28,7 @@ (define-command fundamental-mode (newline e) #:bind-key "C-m" #:bind-key "C-j" - (buffer-insert! (current-editor-buffer e) (string->rope "\n"))) + (buffer-insert! (editor-active-buffer e) (string->rope "\n"))) (define (move-forward-n-lines buf count) (for ((i count)) @@ -49,17 +48,17 @@ (define-command fundamental-mode (forward-char e #:prefix-arg [count 1]) #:bind-key "C-f" #:bind-key "" - (buffer-move-by! (current-editor-buffer e) count)) + (buffer-move-by! (editor-active-buffer e) count)) (define-command fundamental-mode (backward-char e #:prefix-arg [count 1]) #:bind-key "C-b" #:bind-key "" - (buffer-move-by! (current-editor-buffer e) (- count))) + (buffer-move-by! (editor-active-buffer e) (- count))) (define-command fundamental-mode (next-line e #:prefix-arg [count 1]) #:bind-key "C-n" #:bind-key "" - (define buf (current-editor-buffer e)) + (define buf (editor-active-buffer e)) (define col (buffer-column buf)) (move-forward-n-lines buf count) (move-to-column buf col)) @@ -67,7 +66,7 @@ (define-command fundamental-mode (prev-line e #:prefix-arg [count 1]) #:bind-key "C-p" #:bind-key "" - (define buf (current-editor-buffer e)) + (define buf (editor-active-buffer e)) (define col (buffer-column buf)) (move-backward-n-lines buf count) (move-to-column buf col)) @@ -75,21 +74,21 @@ (define-command fundamental-mode (move-end-of-line e #:prefix-arg [count 1]) #:bind-key "C-e" #:bind-key "" - (define buf (current-editor-buffer e)) + (define buf (editor-active-buffer e)) (when (positive? count) (move-forward-n-lines buf (- count 1))) (buffer-move-to-end-of-line! buf)) (define-command fundamental-mode (move-beginning-of-line e #:prefix-arg [count 1]) #:bind-key "C-a" #:bind-key "" - (define buf (current-editor-buffer e)) + (define buf (editor-active-buffer e)) (when (positive? count) (move-forward-n-lines buf (- count 1))) (buffer-move-to-start-of-line! buf)) (define-command fundamental-mode (delete-backward-char e #:prefix-arg [count 1]) #:bind-key "" #:bind-key "C-h" ;; differs from GNU emacs - (define buf (current-editor-buffer e)) + (define buf (editor-active-buffer e)) (buffer-region-update! buf (lambda (_deleted) (empty-rope)) #:mark (- (buffer-pos buf) count))) @@ -97,7 +96,7 @@ (define-command fundamental-mode (delete-forward-char e #:prefix-arg [count 1]) #:bind-key "" #:bind-key "C-d" - (define buf (current-editor-buffer e)) + (define buf (editor-active-buffer e)) (buffer-region-update! buf (lambda (_deleted) (empty-rope)) #:mark (+ (buffer-pos buf) count))) @@ -106,20 +105,20 @@ #:bind-key "M-<" #:bind-key "C-" #:bind-key "" - (define buf (current-editor-buffer e)) + (define buf (editor-active-buffer e)) (if (eq? tenths '#:prefix) (set! tenths 0) (buffer-mark! buf)) (buffer-move-to! buf (* (buffer-size buf) (max 0 (min 10 tenths)) 1/10))) (define-command fundamental-mode (end-of-buffer e #:prefix-arg [tenths 0]) #:bind-key "M->" #:bind-key "C-" - (define buf (current-editor-buffer e)) + (define buf (editor-active-buffer e)) (if (eq? tenths '#:prefix) (set! tenths 0) (buffer-mark! buf)) (buffer-move-to! buf (* (buffer-size buf) (- 10 (max 0 (min 10 tenths))) 1/10))) (define-command fundamental-mode (exchange-point-and-mark e) #:bind-key "C-x C-x" - (define buf (current-editor-buffer e)) + (define buf (editor-active-buffer e)) (define m (buffer-mark-pos buf)) (when m (define p (buffer-pos buf)) @@ -129,7 +128,7 @@ (define-command fundamental-mode (set-mark-command e #:prefix-arg arg) #:bind-key "C-@" #:bind-key "C-space" - (define buf (current-editor-buffer e)) + (define buf (editor-active-buffer e)) (if (eq? arg '#:prefix) (let ((m (buffer-mark-pos buf))) (and m (buffer-move-to! buf m))) diff --git a/rmacs/render.rkt b/rmacs/render.rkt index 88e4b25..e1e93a5 100644 --- a/rmacs/render.rkt +++ b/rmacs/render.rkt @@ -59,6 +59,35 @@ #:foreground-color color-black #:background-color color-white)) +(define (format-line line window-width cursor-input-pos) + (let loop ((chars (string->list line)) + (remaining-width window-width) + (cursor-input-pos cursor-input-pos) + (acc-rev '()) + (cursor-offset (if (zero? cursor-input-pos) 0 #f))) + (define (finish) (values (list->string (reverse acc-rev)) cursor-offset)) + (match chars + ['() (finish)] + [(cons c rest) + (define (emit str) + (define needed (string-length str)) + (if (>= remaining-width needed) + (loop rest + (- remaining-width needed) + (- cursor-input-pos 1) + (append (reverse (string->list str)) acc-rev) + (if (zero? cursor-input-pos) + (length acc-rev) + cursor-offset)) + (finish))) + (match c + [#\tab + (emit (make-string (- 8 (modulo (length acc-rev) 8)) #\space))] + [(? char-iso-control?) + (emit (format "[~x]" (char->integer c)))] + [_ + (emit (string c))])]))) + (define (render-buffer! t b window-top window-height is-active?) (define available-line-count (- window-height 1)) (define top-of-window-pos (frame-buffer! b available-line-count)) @@ -75,14 +104,15 @@ [else (define eol-pos (buffer-findf b newline? #:position sol-pos)) (define line (rope->string (buffer-region b #:point eol-pos #:mark sol-pos))) - (tty-display t line) + (define-values (formatted-line cursor-offset) + (format-line line (tty-columns t) (- cursor-pos sol-pos))) + (tty-display t formatted-line) (tty-clear-to-eol t) (tty-newline t) (loop (+ line-count 1) (+ eol-pos 1) - (if (<= sol-pos cursor-pos eol-pos) - (list (+ line-count window-top) - (- cursor-pos sol-pos)) + (if cursor-offset + (list (+ line-count window-top) cursor-offset) cursor-coordinates))]))) (tty-statusline-style t is-active?) (tty-display t (if is-active? "== " "-- ") (buffer-title b) " ")