diff --git a/rmacs/TODO b/rmacs/TODO index 20d230e..be84b45 100644 --- a/rmacs/TODO +++ b/rmacs/TODO @@ -1,5 +1,19 @@ Make it reloadable -Incremental display repair - Windows need their own top-of-window-mtype and point location + +Preserve column on up/down better. This includes dealing with tab expansion + +Bundle up all mutable command context into a single record, to let the +command handler have everything it needs even in the face of change + +Need line wrap of some kind. + +unknown-escape-sequence contents are byte strings, and keyseq parsing +and printing should reflect that. + +something to do with framing is broken, causing odd scroll-lock +behaviour near the end of the demo file. + +Catch and handle SIGWINCH. +See http://man7.org/tlpi/code/online/dist/tty/demo_SIGWINCH.c.html diff --git a/rmacs/display.rkt b/rmacs/display.rkt index 15a877e..b0bcf80 100644 --- a/rmacs/display.rkt +++ b/rmacs/display.rkt @@ -1,124 +1,96 @@ #lang racket/base (provide (struct-out tty) + (struct-out pen) + stdin-tty + tty-rows + tty-columns tty-last-row tty-last-column - stdin-tty + tty-cursor-row + tty-cursor-column tty-display tty-newline tty-clear tty-clear-to-eol tty-reset tty-goto - tty-style - tty-style-reset + tty-set-pen! + tty-pen + tty-flush tty-next-key tty-next-key-evt ;; From ansi - color-black - color-red - color-green - color-yellow - color-blue - color-magenta - color-cyan - color-white) + (rename-out [ansi:color-black color-black] + [ansi:color-red color-red] + [ansi:color-green color-green] + [ansi:color-yellow color-yellow] + [ansi:color-blue color-blue] + [ansi:color-magenta color-magenta] + [ansi:color-cyan color-cyan] + [ansi:color-white color-white])) (require racket/set) (require racket/match) -(require ansi) +(require (only-in racket/vector vector-copy)) +(require (prefix-in ansi: ansi)) + +(require "diff.rkt") + +(struct pen (foreground-color ;; Nat + background-color ;; Nat + bold? ;; Boolean + italic? ;; Boolean + ) #:prefab) + +(struct screen (rows ;; Nat + columns ;; Nat + [cursor-row #:mutable] ;; Nat + [cursor-column #:mutable] ;; Nat + [pen #:mutable] ;; Pen + contents ;; (Vector[rows] (Vector[columns] (Cons Pen Character))) + ) #:prefab) (struct tty (input ;; InputPort output ;; OutputPort key-reader ;; InputPort -> Key - [rows #:mutable] ;; Nat - [columns #:mutable] ;; Nat - [cursor-row #:mutable] ;; Nat - [cursor-column #:mutable] ;; Nat - [foreground-color #:mutable] ;; Nat - [background-color #:mutable] ;; Nat - [bold? #:mutable] ;; Boolean - [italic? #:mutable] ;; Boolean + [displayed-screen #:mutable] ;; Screen + [pending-screen #:mutable] ;; Screen ) #:prefab) -(define (tty-last-row t) (- (tty-rows t) 1)) -(define (tty-last-column t) (- (tty-columns t) 1)) +(define (make-screen rows columns pen) + (define contents (for/vector ((row rows)) (make-vector columns (cons pen #\space)))) + (screen rows columns 0 0 pen contents)) + +(define (copy-screen s) + (match-define (screen rows columns cursor-row cursor-column pen contents) s) + (define new-contents (for/vector ((row rows)) (vector-copy (vector-ref contents row)))) + (screen rows columns cursor-row cursor-column pen new-contents)) + +(define *pen-white-on-black* (pen ansi:color-white ansi:color-black #f #f)) (define *stdin-tty* #f) (define (stdin-tty) (when (not *stdin-tty*) - (tty-raw!) + (ansi:tty-raw!) (set! *stdin-tty* (tty (current-input-port) (current-output-port) - lex-lcd-input - 24 - 80 - 0 - 0 - color-white - color-black - #f - #f)) - (tty-reset *stdin-tty*) + ansi:lex-lcd-input + (make-screen 24 80 *pen-white-on-black*) + (make-screen 24 80 *pen-white-on-black*))) + (reset *stdin-tty*) (plumber-add-flush! (current-plumber) (lambda (h) - (tty-display *stdin-tty* - (select-graphic-rendition style-normal)) - (tty-goto *stdin-tty* (tty-last-row *stdin-tty*) 0)))) + (output *stdin-tty* + (ansi:select-graphic-rendition ansi:style-normal) + (ansi:goto (tty-rows *stdin-tty*) 1)) + (flush *stdin-tty*)))) *stdin-tty*) -(define (tty-display tty . items) - (for ((i items)) (display i (tty-output tty))) - (flush-output (tty-output tty))) - -(define (tty-newline tty) - (tty-display tty "\r\n")) - -(define (tty-goto tty row0 column0) - (define row (max 0 (min (tty-last-row tty) row0))) - (define column (max 0 (min (tty-last-column tty) column0))) - (tty-display tty (goto (+ row 1) (+ column 1))) - (set-tty-cursor-row! tty row) - (set-tty-cursor-column! tty column) - tty) - -(define (tty-clear tty) - (tty-style tty) ;; applies style from tty - (tty-display tty (clear-screen/home)) - (set-tty-cursor-row! tty 0) - (set-tty-cursor-column! tty 0) - tty) - -(define (tty-clear-to-eol tty) - (tty-display tty (clear-to-eol)) - tty) - -(define (tty-style tty - #:foreground-color [fgcolor (tty-foreground-color tty)] - #:background-color [bgcolor (tty-background-color tty)] - #:bold? [bold? (tty-bold? tty)] - #:italic? [italic? (tty-italic? tty)]) - (tty-display tty - (select-graphic-rendition) - (apply select-graphic-rendition - `(,@(if bold? (list style-bold) (list)) - ,@(if italic? (list style-italic/inverse) (list)) - ,(style-text-color fgcolor) - ,(style-background-color bgcolor)))) - (set-tty-foreground-color! tty fgcolor) - (set-tty-background-color! tty bgcolor) - (set-tty-bold?! tty bold?) - (set-tty-italic?! tty italic?) - tty) - -(define (tty-style-reset tty) - (tty-style tty - #:foreground-color color-white - #:background-color color-black - #:bold? #f - #:italic? #f)) +;;--------------------------------------------------------------------------- +;; Actually send changes to the display (define (collect-position-report tty) (let loop () @@ -126,27 +98,235 @@ (handle-evt (tty-input tty) (lambda (p) (match ((tty-key-reader tty) p) - [(? position-report? r) r] + [(? ansi:position-report? r) r] [_ (loop)])))))) -(define (tty-reset tty) - (tty-display tty - (clear-screen) - (goto 999 999) - (position-report-request)) +(define (reset tty) + (output tty + (ansi:clear-screen) + (ansi:goto 999 999) + (ansi:position-report-request)) + (flush tty) (define report (or (collect-position-report tty) - (position-report 24 80))) ;; TODO: have a more flexible fallback - (tty-clear tty) - (set-tty-rows! tty (position-report-row report)) - (set-tty-columns! tty (position-report-column report)) + (ansi:position-report 24 80))) ;; TODO: have a more flexible fallback + ;; (set! report (ansi:position-report 5 10)) + (define rows (ansi:position-report-row report)) + (define columns (ansi:position-report-column report)) + (set-pen tty *pen-white-on-black* #:force #t) + (clear tty) + (flush tty) + (set-tty-displayed-screen! tty (make-screen rows columns *pen-white-on-black*)) + (set-tty-pending-screen! tty (make-screen rows columns *pen-white-on-black*)) tty) +(define (set-pen tty p #:force [force #f]) + (match-define (pen fgcolor bgcolor bold? italic?) p) + (when (or force (not (equal? p (screen-pen (tty-displayed-screen tty))))) + (output tty + (apply ansi:select-graphic-rendition + `(,@(if bold? (list ansi:style-bold) (list)) + ,@(if italic? (list ansi:style-italic/inverse) (list)) + ,(ansi:style-text-color fgcolor) + ,(ansi:style-background-color bgcolor)))) + (set-screen-pen! (tty-displayed-screen tty) p)) + tty) + +(define (clear tty) + (output tty (ansi:clear-screen/home)) + (set-screen-cursor-row! (tty-displayed-screen tty) 0) + (set-screen-cursor-column! (tty-displayed-screen tty) 0) + tty) + +(define (delete-lines tty n) + (define s (tty-displayed-screen tty)) + (output tty (ansi:delete-lines n)) + (define blank-line (make-vector (screen-columns s) (cons 'unknown #\space))) + (vector-copy! (screen-contents s) + (screen-cursor-row s) + (screen-contents s) + (+ (screen-cursor-row s) n) + (screen-rows s)) + (for ((i (in-range (- (screen-rows s) n) (screen-rows s)))) + (vector-set! (screen-contents s) i blank-line)) + tty) + +(define (insert-lines tty n) + (define s (tty-displayed-screen tty)) + (set-pen tty (car (vector-ref (vector-ref (screen-contents s) + (max 0 (- (screen-cursor-row s) 1))) + (screen-cursor-column s)))) + (output tty (ansi:insert-lines n)) + (define blank-line (make-vector (screen-columns s) (cons (screen-pen s) #\space))) + (vector-copy! (screen-contents s) + (+ (screen-cursor-row s) n) + (screen-contents s) + (screen-cursor-row s) + (- (screen-rows s) n)) + (for ((i (in-range (screen-cursor-row s) (+ (screen-cursor-row s) n)))) + (vector-set! (screen-contents s) i blank-line)) + tty) + +(define (output tty . items) + (for ((i items)) (display i (tty-output tty)))) + +(define (flush tty) + (flush-output (tty-output tty))) + +;;--------------------------------------------------------------------------- +;; Display to buffered screen + +(define (tty-rows t) (screen-rows (tty-pending-screen t))) +(define (tty-columns t) (screen-columns (tty-pending-screen t))) + +(define (tty-last-row t) (- (tty-rows t) 1)) +(define (tty-last-column t) (- (tty-columns t) 1)) + +(define (tty-cursor-row t) (screen-cursor-row (tty-pending-screen t))) +(define (tty-cursor-column t) (screen-cursor-column (tty-pending-screen t))) + +(define (putc tty ch) + (define s (tty-pending-screen tty)) + (match ch + [#\return + (tty-goto tty (screen-cursor-row s) 0)] + [#\newline + (tty-goto tty (+ (screen-cursor-row s) 1) (screen-cursor-column s))] + [#\tab + (for ((i (- 8 (modulo (screen-cursor-column s) 8)))) (putc tty #\space))] + [(? char-iso-control?) + (puts tty (format "[~x]" (char->integer ch)))] + [_ + (when (< (screen-cursor-column s) (screen-columns s)) + ;; (tty-goto tty (+ (screen-cursor-row s) 1) 0) + (vector-set! (vector-ref (screen-contents s) (screen-cursor-row s)) + (screen-cursor-column s) + (cons (screen-pen s) ch))) + (set-screen-cursor-column! s (+ (screen-cursor-column s) 1))])) + +(define (puts tty s) + (for ((ch s)) (putc tty ch))) + +(define (tty-display tty . strings) + (for ((s strings)) (puts tty s))) + +(define (tty-newline tty) + (putc tty #\return) + (putc tty #\newline)) + +(define (tty-clear tty) + (set-tty-pending-screen! tty (make-screen (tty-rows tty) (tty-columns tty) (tty-pen tty))) + tty) + +(define (tty-clear-to-eol tty) + (define start-column (tty-cursor-column tty)) + (for ((i (- (tty-columns tty) (tty-cursor-column tty)))) (putc tty #\space)) + (tty-goto tty (tty-cursor-row tty) start-column) + tty) + +(define (tty-reset tty) + (reset tty) + tty) + +(define (tty-goto tty row0 column0) + (define row (max 0 (min (tty-last-row tty) row0))) + (define column (max 0 (min (tty-last-column tty) column0))) + (set-screen-cursor-row! (tty-pending-screen tty) row) + (set-screen-cursor-column! (tty-pending-screen tty) column) + tty) + +(define (tty-set-pen! tty pen) + (set-screen-pen! (tty-pending-screen tty) pen) + tty) + +(define (tty-pen tty) + (screen-pen (tty-pending-screen tty))) + +;; (define (dump-screen s) +;; (list 'screen +;; (screen-rows s) +;; (screen-columns s) +;; (screen-cursor-row s) +;; (screen-cursor-column s) +;; (list->string +;; (for*/list ((line (screen-contents s)) +;; (cell line) +;; #:when (not (equal? (cdr cell) #\space))) +;; (cdr cell))))) + +(define (goto-if-needed s row column) + (if (and (= (screen-cursor-row s) row) + (= (screen-cursor-column s) column)) + "" + (begin0 (ansi:goto (+ row 1) (+ column 1)) + (set-screen-cursor-row! s row) + (set-screen-cursor-column! s column)))) + +(define (advance-cursor! s) + (set-screen-cursor-column! s (+ (screen-cursor-column s) 1)) + (when (= (screen-cursor-column s) (screen-columns s)) + (set-screen-cursor-column! s 0) + (set-screen-cursor-row! s (+ (screen-cursor-row s) 1)))) + +(define (tty-flush tty) + ;; (set-pen tty *pen-white-on-black* #:force #t) + ;; (clear tty) + (define old (tty-displayed-screen tty)) + (define new (tty-pending-screen tty)) + (define patches (diff-indices (screen-contents old) (screen-contents new))) + + ;; Proceed in two stages: + ;; - delete unwanted lines + ;; - insert and blank lines + + (for/fold [(skew 0)] + [(patch patches)] + (match-define (list patch-old-line patch-old-count patch-new-line patch-new-count) patch) + (define delta-lines (- patch-new-count patch-old-count)) + (define first-row (+ patch-old-line skew)) + (if (negative? delta-lines) + (begin (output tty (goto-if-needed old first-row (screen-cursor-column old))) + (delete-lines tty (- delta-lines)) + (+ skew delta-lines)) + skew)) + + (for/fold [(skew 0)] + [(patch patches)] + (match-define (list patch-old-line patch-old-count patch-new-line patch-new-count) patch) + (define delta-lines (- patch-new-count patch-old-count)) + (define first-row (+ patch-old-line skew)) + (when (positive? delta-lines) + (output tty (goto-if-needed old first-row (screen-cursor-column old))) + (insert-lines tty delta-lines)) + (for ((row (in-range first-row (+ patch-old-line skew patch-new-count)))) + (define old-line (vector-ref (screen-contents old) row)) + (define new-line (vector-ref (screen-contents new) row)) + ;; TODO: consider diffing old-line and new-line and applying + ;; patches rather than just blitting out the whole line + ;; whereever it is different. + (for ((column (screen-columns new))) + (match-define (cons old-pen old-ch) (vector-ref old-line column)) + (match-define (cons new-pen new-ch) (vector-ref new-line column)) + (when (not (and (equal? old-pen new-pen) (equal? old-ch new-ch))) + (set-pen tty new-pen) + (output tty (goto-if-needed old row column) new-ch) + (advance-cursor! old)))) + (+ skew delta-lines)) + + (output tty (goto-if-needed old (screen-cursor-row new) (screen-cursor-column new))) + (flush tty) + (set-tty-displayed-screen! tty new) + (set-tty-pending-screen! tty (copy-screen new)) + tty) + +;;--------------------------------------------------------------------------- +;; Input + (define (tty-next-key tty) - (define k (lex-lcd-input (tty-input tty))) - (if (equal? k (key #\[ (set 'control))) ;; ESC + (define k (ansi:lex-lcd-input (tty-input tty))) + (if (equal? k (ansi:key #\[ (set 'control))) ;; ESC (or (sync/timeout 0.5 (handle-evt (tty-next-key-evt tty) - (lambda (k) (add-modifier 'meta k)))) + (lambda (k) (ansi:add-modifier 'meta k)))) k) k)) diff --git a/rmacs/editor.rkt b/rmacs/editor.rkt index 61c815d..66d80c8 100644 --- a/rmacs/editor.rkt +++ b/rmacs/editor.rkt @@ -8,6 +8,7 @@ editor-active-modeset editor-mainloop editor-request-shutdown! + editor-force-redisplay! ) (require racket/match) @@ -99,41 +100,62 @@ (editor-mainloop editor))]) (let loop ((total-keyseq '()) (input '()) - (handler (root-keyseq-handler editor))) + (handler (root-keyseq-handler editor)) + (next-repaint-deadline 0)) + (define (request-repaint) (or next-repaint-deadline (+ (current-inexact-milliseconds) 20))) (define (wait-for-input next-handler) - (render-editor! editor) (when (editor-running? editor) - (sync (handle-evt (tty-next-key-evt (editor-tty editor)) + (sync (if next-repaint-deadline + (handle-evt (alarm-evt next-repaint-deadline) + (lambda (_) + (loop total-keyseq '() next-handler next-repaint-deadline))) + never-evt) + (handle-evt (tty-next-key-evt (editor-tty editor)) (lambda (new-key) (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 input) - [(unbound-key-sequence) - (if (invoke-command 'unbound-key-sequence (editor-active-buffer 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)] - [(command-invocation selector prefix-arg remaining-input) - (define accepted-input - (let remove-tail ((keyseq total-keyseq)) - (if (equal? keyseq remaining-input) - '() - (cons (car keyseq) (remove-tail (cdr keyseq)))))) - (invoke-command selector (editor-active-buffer editor) - #:keyseq accepted-input - #:prefix-arg prefix-arg) - (loop '() remaining-input (root-keyseq-handler editor))]))))) + (loop (append total-keyseq new-input) + new-input + next-handler + next-repaint-deadline)))))) + (cond + [(and next-repaint-deadline (>= (current-inexact-milliseconds) next-repaint-deadline)) + (render-editor! editor) + (loop total-keyseq input handler #f)] + [(null? input) + (wait-for-input handler)] + [else + (match (handler editor input) + [(unbound-key-sequence) + (if (invoke-command 'unbound-key-sequence (editor-active-buffer editor) + #:keyseq total-keyseq) + (loop '() '() (root-keyseq-handler editor) (request-repaint)) + (error 'editor-mainloop "Unbound key sequence: ~a" + (keyseq->keyspec total-keyseq)))] + [(incomplete-key-sequence next-handler) + (wait-for-input next-handler)] + [(command-invocation selector prefix-arg remaining-input) + (define accepted-input + (let remove-tail ((keyseq total-keyseq)) + (if (equal? keyseq remaining-input) + '() + (cons (car keyseq) (remove-tail (cdr keyseq)))))) + (invoke-command selector (editor-active-buffer editor) + #:keyseq accepted-input + #:prefix-arg prefix-arg) + (loop '() remaining-input (root-keyseq-handler editor) (request-repaint))])])))) (define (editor-request-shutdown! editor) (set-editor-running?! editor #f)) +(define (editor-force-redisplay! editor) + (tty-reset (editor-tty editor))) + ;;--------------------------------------------------------------------------- (define-command kernel-mode (save-buffers-kill-terminal buf) #:bind-key "C-x C-c" (editor-request-shutdown! (buffer-editor buf))) + +(define-command kernel-mode (force-redisplay buf) + #:bind-key "C-l" + (editor-force-redisplay! (buffer-editor buf))) diff --git a/rmacs/main.rkt b/rmacs/main.rkt index 527f7bb..adf0160 100644 --- a/rmacs/main.rkt +++ b/rmacs/main.rkt @@ -15,4 +15,6 @@ (editor-mainloop e)) (module+ main + (local-require racket/trace) + (current-trace-notify (lambda (s) (log-info "TRACE: ~a" s))) (void (main))) diff --git a/rmacs/render.rkt b/rmacs/render.rkt index 14ee4f4..4881745 100644 --- a/rmacs/render.rkt +++ b/rmacs/render.rkt @@ -49,15 +49,10 @@ new-top-of-window-pos)]))) (define (tty-body-style t is-active?) - (tty-style t - #:foreground-color color-white - #:background-color color-blue - #:bold? #f)) + (tty-set-pen! t (pen color-white color-blue #f #f))) (define (tty-statusline-style t is-active?) - (tty-style t - #:foreground-color color-black - #:background-color color-white)) + (tty-set-pen! t (pen color-black color-white #f #f))) (define (format-line line window-width cursor-input-pos) (let loop ((chars (string->list line)) @@ -117,8 +112,9 @@ cursor-coordinates))]))) (tty-statusline-style t is-active?) (tty-display t (if is-active? "== " "-- ") (buffer-title b) " ") - (tty-display t (make-string (- (tty-columns t) 4 (string-length (buffer-title b))) - (if is-active? #\= #\-))) + (let ((remaining-length (- (tty-columns t) 4 (string-length (buffer-title b))))) + (when (positive? remaining-length) + (tty-display t (make-string remaining-length (if is-active? #\= #\-))))) cursor-coordinates) (define (layout-windows ws total-height [minimum-height 4]) @@ -160,4 +156,5 @@ (define window-cursor-position (render-buffer! t b window-top window-height is-active?)) (if is-active? window-cursor-position cursor-position))) (when active-cursor-position - (tty-goto t (car active-cursor-position) (cadr active-cursor-position)))) + (tty-goto t (car active-cursor-position) (cadr active-cursor-position))) + (tty-flush t))