From 887155e5ec1f5f75194c9c144d6424ce4ec128dd Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Tue, 23 Dec 2014 01:43:01 -0500 Subject: [PATCH] Much progress --- rmacs/buffer.rkt | 107 +++++++++++---- rmacs/display.rkt | 9 ++ rmacs/editor.rkt | 87 ++++++++++++- rmacs/keys.rkt | 228 ++++++++++++++++++++++++++++++++ rmacs/main.rkt | 20 ++- rmacs/mode.rkt | 258 +++++++++++++++++++++++++++++++++++++ rmacs/mode/fundamental.rkt | 136 +++++++++++++++++++ rmacs/render.rkt | 21 +-- rmacs/rope.rkt | 3 +- rmacs/topsort.rkt | 54 ++++++++ 10 files changed, 873 insertions(+), 50 deletions(-) create mode 100644 rmacs/keys.rkt create mode 100644 rmacs/mode.rkt create mode 100644 rmacs/mode/fundamental.rkt create mode 100644 rmacs/topsort.rkt diff --git a/rmacs/buffer.rkt b/rmacs/buffer.rkt index 8135c84..91eb6a6 100644 --- a/rmacs/buffer.rkt +++ b/rmacs/buffer.rkt @@ -14,15 +14,25 @@ buffer-pos buffer-title buffer-group + buffer-modeset + buffer-column + buffer-add-mode! + buffer-remove-mode! + buffer-toggle-mode! buffer-size buffer-move-to! buffer-move-by! + buffer-start-of-line + buffer-end-of-line + buffer-move-to-start-of-line! + buffer-move-to-end-of-line! buffer-mark! buffer-clear-mark! buffer-mark-pos buffer-region-split buffer-region buffer-region-update! + buffer-insert! call-with-excursion buffer-search buffer-findf) @@ -30,6 +40,7 @@ (require "rope.rkt") (require "search.rkt") (require "circular-list.rkt") +(require "mode.rkt") (require (only-in racket/string string-join)) (require (only-in racket/path normalize-path)) @@ -44,6 +55,7 @@ [pos #:mutable] [title #:mutable] [group #:mutable] ;; (Option BufferGroup) + [modeset #:mutable] ;; ModeSet ) #:prefab) (define (make-buffergroup) @@ -55,7 +67,8 @@ (register-buffer! group (buffer (string->rope initial-contents) 0 title - #f))) + #f + kernel-modeset))) (define (register-buffer! group buf) (define old-group (buffer-group buf)) @@ -114,7 +127,8 @@ (buffer-region-update! b (lambda (_dontcare) (string->rope (file->string filename))) #:point 0 - #:mark (buffer-size b)))) + #:mark (buffer-size b)) + (buffer-move-to! b 0))) (define (buffer-rename! b new-title) (if (title-exists-in-group? (buffer-group b) new-title) @@ -136,8 +150,22 @@ (define (buffer-size buf) (rope-size (buffer-rope buf))) -(define (buffer-move-to! buf pos) - (set-buffer-pos! buf (max 0 (min (buffer-size buf) pos))) +(define (buffer-column buf) + (- (buffer-pos buf) (buffer-start-of-line buf))) + +(define (buffer-add-mode! buf mode) + (set-buffer-modeset! buf (modeset-add-mode (buffer-modeset buf) mode))) +(define (buffer-remove-mode! buf mode) + (set-buffer-modeset! buf (modeset-remove-mode (buffer-modeset buf) mode))) +(define (buffer-toggle-mode! buf mode) + (set-buffer-modeset! buf (modeset-toggle-mode (buffer-modeset buf) mode))) + +(define (clamp pos buf) + (max 0 (min (buffer-size buf) pos))) + +(define (buffer-move-to! buf pos0) + (define pos (clamp pos0 buf)) + (set-buffer-pos! buf pos) (buffer-seek! buf pos)) (define (buffer-seek! buf pos) @@ -146,10 +174,22 @@ (define (buffer-move-by! buf delta) (buffer-move-to! buf (+ (buffer-pos buf) delta))) -(define (buffer-mark! buf [mtype main-mark-type] #:position [pos (buffer-pos buf)] #:value [value #t]) +(define (buffer-start-of-line buf) + (buffer-findf buf (lambda (ch) (equal? ch #\newline)) #:forward? #f)) + +(define (buffer-end-of-line buf) + (buffer-findf buf (lambda (ch) (equal? ch #\newline)) #:forward? #t)) + +(define (buffer-move-to-start-of-line! buf) + (buffer-move-to! buf (buffer-start-of-line buf))) + +(define (buffer-move-to-end-of-line! buf) + (buffer-move-to! buf (buffer-end-of-line buf))) + +(define (buffer-mark! buf [pos (buffer-pos buf)] #:mark-type [mtype main-mark-type] #:value [value #t]) (buffer-lift replace-mark buf mtype pos value)) -(define (buffer-clear-mark! buf [mtype main-mark-type]) +(define (buffer-clear-mark! buf #:mark-type [mtype main-mark-type]) (define pos (find-mark-pos (buffer-rope buf) mtype)) (if pos (buffer-lift clear-mark buf mtype pos) @@ -159,11 +199,11 @@ (find-mark-pos (buffer-rope buf) mtype)) (define (buffer-region-split* buf pos mark) - (define lo (min pos mark)) - (define hi (max pos mark)) + (define lo (clamp (min pos mark) buf)) + (define hi (clamp (max pos mark) buf)) (define-values (l mr) (rope-split (buffer-rope buf) lo)) (define-values (m r) (rope-split mr (- hi lo))) - (values l m r)) + (values l lo m hi r)) (define (buffer-region-split buf #:point [pos (buffer-pos buf)] @@ -173,29 +213,44 @@ (define (buffer-region buf #:point [pos (buffer-pos buf)] #:mark [mark (buffer-mark-pos buf)]) - (define-values (_l m _r) (buffer-region-split* buf pos mark)) + (define-values (_l _lo m _hi _r) (buffer-region-split* buf pos mark)) m) (define (buffer-region-update! buf updater #:point [pos (buffer-pos buf)] #:mark [mark (buffer-mark-pos buf)]) - (define-values (l m r) (buffer-region-split* buf pos mark)) - (set-buffer-rope! buf (rope-concat (list l (updater m) r))) + (define-values (l lo old-m hi r) (buffer-region-split* buf pos mark)) + (define new-m (updater old-m)) + (define delta (- (rope-size new-m) (rope-size old-m))) + (set-buffer-rope! buf (rope-append (rope-append l new-m) r)) + (cond + [(<= lo (buffer-pos buf) hi) (buffer-move-to! buf (+ hi delta))] + [(> (buffer-pos buf) hi) (buffer-move-by! buf delta)] + [else buf])) + +(define (buffer-insert! buf content-rope + #:point [pos0 (buffer-pos buf)] + #:move? [move? #t]) + (define pos (clamp pos0 buf)) + (define-values (l r) (rope-split (buffer-rope buf) pos)) + (set-buffer-rope! buf (rope-append (rope-append l content-rope) r)) + (when (>= (buffer-pos buf) pos) + (set-buffer-pos! buf (+ (buffer-pos buf) (rope-size content-rope)))) buf) (define (call-with-excursion buf f) (define excursion (gensym 'excursion)) (define saved-mark-type (mark-type (format "Saved mark ~a" excursion) 'right)) (define saved-point-type (mark-type (format "Saved point ~a" excursion) 'right)) - (buffer-mark! buf saved-mark-type #:position (buffer-mark-pos buf)) - (buffer-mark! buf saved-point-type #:position (buffer-pos buf)) + (buffer-mark! buf (buffer-mark-pos buf) #:mark-type saved-mark-type) + (buffer-mark! buf (buffer-pos buf) #:mark-type saved-point-type) (define (restore!) (define restore-mark-pos (buffer-mark-pos buf saved-mark-type)) (define restore-point-pos (buffer-mark-pos buf saved-point-type)) - (when restore-mark-pos (buffer-mark! buf #:position restore-mark-pos)) + (when restore-mark-pos (buffer-mark! buf restore-mark-pos)) (when restore-point-pos (buffer-move-to! buf restore-point-pos)) - (buffer-clear-mark! buf saved-mark-type) - (buffer-clear-mark! buf saved-point-type)) + (buffer-clear-mark! buf #:mark-type saved-mark-type) + (buffer-clear-mark! buf #:mark-type saved-point-type)) (with-handlers [(exn? (lambda (e) (restore!) (raise e)))] @@ -203,15 +258,19 @@ (restore!) result)) -(define (buffer-search* buf start-pos forward? move? find-delta) +(define (buffer-search* buf start-pos0 forward? move? find-delta) + (define start-pos (clamp start-pos0 buf)) (define-values (l r) (rope-split (buffer-rope buf) start-pos)) (define delta (find-delta (if forward? r l))) - (define new-pos (+ start-pos (cond [(not delta) 0] [forward? delta] [else (- delta)]))) - (when delta - (if move? - (buffer-move-to! buf new-pos) - (buffer-seek! buf new-pos))) - new-pos) + (and delta + (let ((new-pos (clamp (+ start-pos (cond [(not delta) 0] + [forward? delta] + [else (- delta (rope-size l))])) + buf))) + (if move? + (buffer-move-to! buf new-pos) + (buffer-seek! buf new-pos)) + new-pos))) (define (buffer-search buf needle #:position [start-pos (buffer-pos buf)] diff --git a/rmacs/display.rkt b/rmacs/display.rkt index 6f1531c..c6eb468 100644 --- a/rmacs/display.rkt +++ b/rmacs/display.rkt @@ -12,6 +12,8 @@ tty-goto tty-style tty-style-reset + tty-next-key + tty-next-key-evt ;; From ansi color-black @@ -136,3 +138,10 @@ (set-tty-rows! tty (position-report-row report)) (set-tty-columns! tty (position-report-column report)) tty) + +(define (tty-next-key tty) + (lex-lcd-input (tty-input tty))) + +(define (tty-next-key-evt tty) + (handle-evt (tty-input tty) + (lambda (_) (tty-next-key tty)))) diff --git a/rmacs/editor.rkt b/rmacs/editor.rkt index 8fc0854..a935ce9 100644 --- a/rmacs/editor.rkt +++ b/rmacs/editor.rkt @@ -4,23 +4,38 @@ make-editor visit-file! render-editor! + current-editor-buffer + current-editor-modeset + editor-invoke-command + editor-mainloop + editor-request-shutdown! ) +(require racket/match) + (require "buffer.rkt") (require "display.rkt") (require "window.rkt") (require "render.rkt") +(require "mode.rkt") +(require "keys.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 ) #:prefab) -(define (make-editor) +(define (make-editor [tty (stdin-tty)]) (define g (make-buffergroup)) (define scratch (make-buffer g "*scratch*" #:initial-contents ";; This is the scratch buffer.")) (define w (make-window scratch)) - (editor g (list (list w (relative-size 1))) w)) + (editor g + tty + (list (list w (relative-size 1))) + w + #f)) (define (visit-file! editor filename) (set-window-buffer! (editor-active-window editor) @@ -28,5 +43,71 @@ filename))) (define (render-editor! editor) - (render-windows! (editor-windows editor) + (render-windows! (editor-tty editor) + (editor-windows editor) (editor-active-window editor))) + +(define (current-editor-buffer editor) + (define w (editor-active-window editor)) + (and w (window-buffer w))) + +(define (current-editor-modeset editor) + (define b (current-editor-buffer editor)) + (and b (buffer-modeset b))) + +(define (root-keyseq-handler editor) + (modeset-keyseq-handler (current-editor-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)) + (when (not cmd) + (error 'main "Unhandled command ~a (key sequence: ~a)" + selector + (keyseq->keyspec keyseq))) + (cmd editor prefix-arg keyseq)) + +(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 '()) + (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) + (wait-for-input handler) + (match (handler editor keys) + [(unbound-key-sequence) + (editor-invoke-command 'unbound-key-sequence editor #:keyseq keys) + (loop '() (root-keyseq-handler editor))] + [(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) + '() + (cons (car input) (loop (cdr input)))))) + (editor-invoke-command selector editor #:keyseq accepted-input #:prefix-arg prefix-arg) + (loop remaining-input (root-keyseq-handler editor))]))))) + +(define (editor-request-shutdown! editor) + (set-editor-running?! editor #f)) + +;;--------------------------------------------------------------------------- + +(define-command kernel-mode (save-buffers-kill-terminal e) + #:bind-key "C-x C-c" + (editor-request-shutdown! e)) diff --git a/rmacs/keys.rkt b/rmacs/keys.rkt new file mode 100644 index 0000000..a1cb5b9 --- /dev/null +++ b/rmacs/keys.rkt @@ -0,0 +1,228 @@ +#lang racket/base +;; Keyspecs, keyseqs and keymaps + +(provide parse-key-sequence + keyspec->keyseq + key->keyspec + keyseq->keyspec + (struct-out keymap) + empty-keymap + keymap-update + keymap-bind + keymap-unbind + keymap-lookup) + +(require racket/set) +(require racket/match) +(require (only-in racket/list append-map)) +(require (only-in racket/string + string-join + string-split + string-trim)) + +(require ansi/lcd-terminal) + +;;--------------------------------------------------------------------------- +;; Key sequence parsing + +(define (read-string-to-end s) + (define p (open-input-string s)) + (define result (read p)) + (and (eof-object? (peek-char p)) + result)) + +(define (bad-key lexeme fmt . args) + (error 'parse-key-sequence "~a in key ~v" (apply format fmt args) (string-trim lexeme))) + +(define (parse-modifiers modifiers lexeme) + (for/set ((mod (string-split (string-upcase modifiers) "-"))) + (match mod + ["C" 'control] + ["S" 'shift] + ["M" 'meta] + [_ (bad-key lexeme "Unknown modifier ~a" mod)]))) + +(define (parse-key-sequence s) + (match s + [(pregexp "^ *#:default(( +.*)|$)" (list lexeme rest _)) + (cons '#:default (parse-key-sequence rest))] + [(pregexp "^ *(([cCsSmM]-)*)\"([^\"]*)\"(.*)" (list lexeme modifiers _ stringspec rest)) + (define mods (parse-modifiers modifiers lexeme)) + (define seq (unknown-escape-sequence (or (read-string-to-end (format "\"~a\"" stringspec)) + (bad-key lexeme "Bad raw input sequence")))) + (cons (key seq mods) (parse-key-sequence rest))] + [(pregexp "^ *(([cCsSmM]-)*)<([^>]+)>(( +.*)|$)" (list lexeme modifiers _ symname rest _)) + (define mods (parse-modifiers modifiers lexeme)) + (cons (key (string->symbol symname) mods) + (parse-key-sequence rest))] + [(pregexp "^ *(([cCsSmM]-)*)(?i:esc)(( +.*)|$)" (list lexeme modifiers _ rest _)) + (define mods (parse-modifiers modifiers lexeme)) + (cons (key #\[ (set-add mods 'control)) (parse-key-sequence rest))] + [(pregexp "^ *(([cCsSmM]-)*)([^ ]+)(( +.*)|$)" (list lexeme modifiers _ keystr rest _)) + (define mods (parse-modifiers modifiers lexeme)) + (define keychar (or (read-string-to-end (format "#\\~a" keystr)) + (bad-key lexeme "Bad single-character key"))) + (cons (key (if (set-member? mods 'control) + (char-upcase keychar) + keychar) + mods) + (parse-key-sequence rest))] + [(pregexp "^ *$") + '()] + [_ (bad-key s "Unexpected junk")])) + +(define (keyspec->keyseq what original-keyspec) + (let convert ((keyspec original-keyspec)) + (cond + [(key? keyspec) (list keyspec)] + [(keyword? keyspec) (list keyspec)] + [(string? keyspec) (parse-key-sequence keyspec)] + [(list? keyspec) (append-map convert keyspec)] + [else (error what "Invalid key specification: ~v" original-keyspec)]))) + +(define (format-modifiers mods suffix) + (if (set-empty? mods) + suffix + (string-append (string-join (map (lambda (m) + (match m + ['control "C"] + ['shift "S"] + ['meta "M"])) + (set->list mods)) + "-") + "-" + suffix))) + +(define (key->keyspec k) + (match k + [(? keyword?) (format "~a" k)] + [(key value modifiers) + (define-values (str updated-modifiers) + (match value + [(unknown-escape-sequence s) + (values (format "~v" s) modifiers)] + [(? symbol? s) + (values (format "<~a>" s) modifiers)] + [#\[ #:when (set-member? modifiers 'control) + (values "ESC" (set-remove modifiers 'control))] + [(? char? c) + (define s (format "~v" c)) + (values (substring s 2 (string-length s)) modifiers)])) + (format-modifiers updated-modifiers str)])) + +(define (keyseq->keyspec keyseq) + (string-join (map key->keyspec keyseq) " ")) + +;;--------------------------------------------------------------------------- +;; Keymaps + +(struct keymap (table + ) #:prefab) + +(define (empty-keymap) + (keymap (hash))) + +(define (keymap-update km keyspec updater) + (define original-keyseq (keyspec->keyseq 'keymap-bind keyspec)) + (let loop ((prefix-rev '()) + (keyseq original-keyseq) + (km km)) + (match keyseq + ['() (updater (reverse prefix-rev) km original-keyseq)] + [(cons k rest) + (cond + [(keymap? km) + (let* ((new (loop (cons k prefix-rev) rest (hash-ref (keymap-table km) k #f))) + (newtab (if new + (hash-set (keymap-table km) k new) + (hash-remove (keymap-table km) k)))) + (if (hash-empty? newtab) + #f + (struct-copy keymap km [table newtab])))] + [(not km) + (loop prefix-rev keyseq (empty-keymap))] + [else + (error 'keymap-update + "Cannot update keyspec ~v, as a shorter prefix ~v exists" + (keyseq->keyspec original-keyseq) + (keyseq->keyspec (reverse prefix-rev)))])]))) + +(define (keymap-bind km keyspec command) + (keymap-update km keyspec (lambda (prefix oldval newseq) + (if oldval + (error 'keymap-bind "Cannot bind ~v, as prefix ~v exists" + (keyseq->keyspec newseq) + (keyseq->keyspec prefix)) + command)))) + +(define (keymap-bind* km specs-and-commands) + (match specs-and-commands + ['() km] + [(cons (list keyspec command) rest) (keymap-bind* (keymap-bind km keyspec command) rest)])) + +(define (keymap-unbind km keyspec) + (or (keymap-update km keyspec (lambda (prefix oldval newseq) #f)) + (empty-keymap))) + +(define (keymap-lookup km keyspec) + (define original-keyseq (keyspec->keyseq 'keymap-lookup keyspec)) + (let loop ((keyseq original-keyseq) + (km km)) + (match keyseq + ['() (values km keyseq)] + [(cons k rest) + (match km + [(keymap table) (loop rest (or (hash-ref table k #f) + (hash-ref table '#:default #f)))] + [_ (values km keyseq)])]))) + +;;--------------------------------------------------------------------------- + +(module+ test + (require rackunit racket/pretty) + + (check-equal? (parse-key-sequence "<") (list (key #\< (set)))) + (check-equal? (parse-key-sequence ">") (list (key #\> (set)))) + (check-equal? (parse-key-sequence "#:default #:default") + (list '#:default '#:default)) + (check-equal? (parse-key-sequence "esc ESC") + (list (key #\[ (set 'control)) + (key #\[ (set 'control)))) + + (define km (keymap-bind* (empty-keymap) (list (list "C-x o" 'other-window) + (list "C-x 2" 'split-window) + (list "C-x 1" 'delete-other-windows) + (list "C-x 0" 'delete-window)))) + (check-equal? km + (keymap (hash (key #\X (set 'control)) + (keymap (hash (key #\o (set)) 'other-window + (key #\2 (set)) 'split-window + (key #\1 (set)) 'delete-other-windows + (key #\0 (set)) 'delete-window))))) + (set! km (keymap-unbind km "C-x 1")) + (check-equal? km + (keymap (hash (key #\X (set 'control)) + (keymap (hash (key #\o (set)) 'other-window + (key #\2 (set)) 'split-window + (key #\0 (set)) 'delete-window))))) + (check-equal? (keymap-unbind (keymap-unbind km "C-x 2") "C-x 0") + (keymap (hash (key #\X (set 'control)) + (keymap (hash (key #\o (set)) 'other-window))))) + (check-equal? (keymap-unbind (keymap-unbind (keymap-unbind km "C-x 2") "C-x 0") "C-x o") + (empty-keymap)) + (check-equal? (keymap-unbind km "C-x") + (empty-keymap)) + + (define (lookup s) + (define-values (result remaining-input) (keymap-lookup km s)) + (list result remaining-input)) + + (check-equal? (lookup "C-x") (list (keymap (hash (key #\o (set)) 'other-window + (key #\2 (set)) 'split-window + (key #\0 (set)) 'delete-window)) + '())) + (check-equal? (lookup "C-x 1") (list #f '())) + (check-equal? (lookup "C-x 2") (list 'split-window '())) + (check-equal? (lookup "C-c") (list #f '())) + (check-equal? (lookup "C-c C-c") (list #f (list (key #\C (set 'control))))) + ) diff --git a/rmacs/main.rkt b/rmacs/main.rkt index d8bcc71..a9dfc0b 100644 --- a/rmacs/main.rkt +++ b/rmacs/main.rkt @@ -1,19 +1,17 @@ #lang racket/base -(require "editor.rkt") -(require "render.rkt") (require racket/match) +(require "editor.rkt") +(require "buffer.rkt") +(require "mode/fundamental.rkt") + (define (main) - (with-handlers ([exn? (lambda (e) - (local-require ansi) - (tty-restore!) - (raise e))]) - (define e (make-editor)) - (visit-file! e (build-path (collection-file-path "main.rkt" "rmacs") - 'up 'up "doc" "xterm_controls.txt")) - (render-editor! e)) - (sleep 2)) + (define e (make-editor)) + (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 (void (main))) diff --git a/rmacs/mode.rkt b/rmacs/mode.rkt new file mode 100644 index 0000000..1ae021e --- /dev/null +++ b/rmacs/mode.rkt @@ -0,0 +1,258 @@ +#lang racket/base +;; Modes and modesets. + +(provide (struct-out mode) + (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 + make-mode + mode-add-constraints + mode-keymap-bind! + mode-keymap-unbind! + mode-keymap-rebind! + mode-define-command! + mode-undefine-command! + mode-redefine-command! + + make-modeset + modeset-add-mode + modeset-remove-mode + modeset-toggle-mode + modeset-keyseq-handler + modeset-lookup-command + + kernel-mode + kernel-modeset + + define-key + define-command) + +(require racket/set) +(require racket/match) +(require (only-in racket/list filter-map)) +(require (for-syntax syntax/parse)) +(require (for-syntax racket/base)) + +(require "keys.rkt") +(require "topsort.rkt") + +(struct mode (id + name + [keymap #:mutable] + [commands #:mutable] + dispatch-keys-before + dispatch-keys-after + interpret-commands-before + interpret-commands-after + ) #:prefab) + +(struct modeset (modes + key-dispatch-order + command-interpretation-order + ) #:prefab) + +(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) + (mode (gensym name) + name + (empty-keymap) + (hasheq) + (seteq) + (seteq) + (seteq) + (seteq))) + +(define (mode-add-constraints m + #:dispatch-keys-before [kb '()] + #:dispatch-keys-after [ka '()] + #:interpret-commands-before [cb '()] + #:interpret-commands-after [ca '()]) + (define (convert modes) (list->seteq (for/list ((m modes)) + (if (keyword? m) + m + (mode-id m))))) + (struct-copy mode m + [dispatch-keys-before + (set-union (mode-dispatch-keys-before m) (convert kb))] + [dispatch-keys-after + (set-union (mode-dispatch-keys-after m) (convert ka))] + [interpret-commands-before + (set-union (mode-interpret-commands-before m) (convert cb))] + [interpret-commands-after + (set-union (mode-interpret-commands-after m) (convert ca))])) + +(define (make-mode name) + (mode-add-constraints (make-raw-mode name) + #:dispatch-keys-before '(#:kernel) + #:interpret-commands-before '(#:kernel))) + +(define (mode-keymap-bind! m keyspec command) + (set-mode-keymap! m (keymap-bind (mode-keymap m) keyspec command)) + m) + +(define (mode-keymap-unbind! m keyspec) + (set-mode-keymap! m (keymap-unbind (mode-keymap m) keyspec)) + m) + +(define (mode-keymap-rebind! m keyspec command) + (mode-keymap-bind! (mode-keymap-unbind! m keyspec) keyspec command)) + +(define (mode-define-command! m selector handler) + (when (hash-has-key? (mode-commands m) selector) + (error 'mode-define-command! + "Duplicate command handler for ~a in mode ~a" + selector + (mode-id m))) + (set-mode-commands! m (hash-set (mode-commands m) selector handler)) + m) + +(define (mode-undefine-command! m selector) + (set-mode-commands! m (hash-remove (mode-commands m) selector)) + m) + +(define (mode-redefine-command! m selector handler) + (mode-define-command! (mode-undefine-command! m selector) selector handler)) + +(define (make-modeset) + (modeset (hasheq) + '() + '())) + +(define (modeset-add-mode ms m) + (compute-modeset-orders + (struct-copy modeset ms [modes (hash-set (modeset-modes ms) + (mode-id m) + m)]))) + +(define (modeset-remove-mode ms m) + (compute-modeset-orders + (struct-copy modeset ms [modes (hash-remove (modeset-modes ms) (mode-id m))]))) + +(define (modeset-toggle-mode ms m) + ((if (hash-has-key? (modeset-modes ms) (mode-id m)) modeset-remove-mode modeset-add-mode) + ms + m)) + +(define (edges ms before-getter after-getter) + (for/fold [(es '())] + [(m (in-hash-values (modeset-modes ms)))] + (define mid (mode-id m)) + (append (for/list [(nid (before-getter m))] (list mid nid)) + (for/list [(nid (after-getter m))] (list nid mid)) + es))) + +(define (compute-modeset-order ms what before-getter after-getter) + (or (topsort (edges ms before-getter after-getter) #:comparison eq?) + (error 'compute-modeset-orders "Inconsistent ~a order: ~v" + (hash-keys (modeset-modes ms))))) + +(define (compute-modeset-orders ms) + (struct-copy modeset ms + [key-dispatch-order (compute-modeset-order ms + "key dispatch" + mode-dispatch-keys-before + mode-dispatch-keys-after)] + [command-interpretation-order (compute-modeset-order ms + "command interpretation" + mode-interpret-commands-before + mode-interpret-commands-after)])) + +(define (order->modes ms order-getter) + (define modes (modeset-modes ms)) + (filter-map (lambda (id) (hash-ref modes id #f)) (order-getter ms))) + +(define (modeset-keyseq-handler ms) + (let handler-for-maps ((maps (map mode-keymap (order->modes ms modeset-key-dispatch-order)))) + (lambda (e ks) + (define results (map (lambda (km) + (define-values (result remaining-input) (keymap-lookup km ks)) + (list result remaining-input)) maps)) + (let process-results ((results results)) + (match results + ['() (unbound-key-sequence)] + [(cons (list result remaining-input) rest) + (cond + [(not result) (process-results rest)] + [(keymap? result) (incomplete-key-sequence + (handler-for-maps (filter keymap? (map car results))))] + [(procedure? result) + (if (null? remaining-input) + (incomplete-key-sequence result) + (result e remaining-input))] + [else (command-invocation result '#:default remaining-input)])]))))) + +(define (modeset-lookup-command ms selector) + (let search ((tables (map mode-commands + (order->modes ms modeset-command-interpretation-order)))) + (match tables + ['() #f] + [(cons table rest) + (define handler (hash-ref table selector #f)) + (if handler + (lambda (e prefix-arg ks) + (handler e + (lambda ([prefix-arg prefix-arg] [ks ks]) + (define next-method (search rest)) + (when next-method (next-method e prefix-arg ks))) + selector + prefix-arg + ks)) + (search rest))]))) + +(define kernel-mode + (mode-add-constraints (make-raw-mode "kernel") + #:dispatch-keys-after '(#:kernel) + #:interpret-commands-after '(#:kernel))) + +(define kernel-modeset + (modeset-add-mode (make-modeset) kernel-mode)) + +;;--------------------------------------------------------------------------- + +(define-syntax-rule (define-key mode-exp keyspec-exp command-symbol) + (mode-keymap-bind! mode-exp keyspec-exp 'command-symbol)) + +(define-syntax define-command + (lambda (stx) + (syntax-parse stx + [(_ mode-exp + (selector editor + (~or (~optional (~seq #:next-method next-method) + #:defaults ([next-method #'nm]) + #:name "#:next-method") + (~optional (~seq #:prefix-arg + (~or (~seq [prefix-arg prefix-default prefix-prefix]) + (~seq [prefix-arg prefix-default]) + prefix-arg)) + #:defaults ([prefix-arg #'pa] + [prefix-default #''#:default] + [prefix-prefix #''#:prefix]) + #:name "#:prefix-arg") + (~optional (~seq #:selector self-selector) + #:defaults ([self-selector #'self]) + #:name "#:self-selector") + (~optional (~seq #:keyseq keyseq) + #:defaults ([keyseq #'keyseq]) + #:name "#:keyseq")) + ...) + (~seq #:bind-key bind-keyspec-exps) ... + body ...) + #`(let ((mode mode-exp)) + (mode-define-command! mode 'selector + (lambda (editor next-method self-selector prefix-arg keyseq) + (let ((prefix-arg (match prefix-arg + ['#:default prefix-default] + ['#:prefix prefix-prefix] + [_ prefix-arg]))) + body ...))) + #,@(for/list ((bind-keyspec-exp (syntax->list #'(bind-keyspec-exps ...)))) + #`(mode-keymap-bind! mode #,bind-keyspec-exp 'selector)) + (void))]))) diff --git a/rmacs/mode/fundamental.rkt b/rmacs/mode/fundamental.rkt new file mode 100644 index 0000000..acc76b1 --- /dev/null +++ b/rmacs/mode/fundamental.rkt @@ -0,0 +1,136 @@ +#lang racket/base + +(provide fundamental-mode) + +(require ansi/lcd-terminal) +(require "../mode.rkt") +(require "../editor.rkt") +(require "../buffer.rkt") +(require "../keys.rkt") +(require "../rope.rkt") + +(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))))) + +(define-command fundamental-mode (unbound-key-sequence e #:keyseq keyseq) + (editor-invoke-command 'self-insert-command e #:keyseq keyseq)) + +(define-key fundamental-mode (list "C-q" '#:default) self-insert-command) + +(define-command fundamental-mode (newline e) + #:bind-key "C-m" + #:bind-key "C-j" + (buffer-insert! (current-editor-buffer e) (string->rope "\n"))) + +(define (move-forward-n-lines buf count) + (for ((i count)) + (buffer-move-to-end-of-line! buf) + (buffer-move-by! buf 1))) + +(define (move-backward-n-lines buf count) + (for ((i count)) + (buffer-move-to-start-of-line! buf) + (buffer-move-by! buf -1))) + +(define (move-to-column buf col) + (define eol-pos (buffer-end-of-line buf)) + (buffer-move-to-start-of-line! buf) + (buffer-move-by! buf (min col (- eol-pos (buffer-pos buf))))) + +(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)) + +(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))) + +(define-command fundamental-mode (next-line e #:prefix-arg [count 1]) + #:bind-key "C-n" + #:bind-key "" + (define buf (current-editor-buffer e)) + (define col (buffer-column buf)) + (move-forward-n-lines buf count) + (move-to-column buf col)) + +(define-command fundamental-mode (prev-line e #:prefix-arg [count 1]) + #:bind-key "C-p" + #:bind-key "" + (define buf (current-editor-buffer e)) + (define col (buffer-column buf)) + (move-backward-n-lines buf count) + (move-to-column buf col)) + +(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)) + (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)) + (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)) + (buffer-region-update! buf + (lambda (_deleted) (empty-rope)) + #:mark (- (buffer-pos buf) count))) + +(define-command fundamental-mode (delete-forward-char e #:prefix-arg [count 1]) + #:bind-key "" + #:bind-key "C-d" + (define buf (current-editor-buffer e)) + (buffer-region-update! buf + (lambda (_deleted) (empty-rope)) + #:mark (+ (buffer-pos buf) count))) + +(define-command fundamental-mode (beginning-of-buffer e #:prefix-arg [tenths 0]) + #:bind-key "M-<" + #:bind-key "C-" + #:bind-key "" + (define buf (current-editor-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)) + (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 m (buffer-mark-pos buf)) + (when m + (define p (buffer-pos buf)) + (buffer-mark! buf p) + (buffer-move-to! buf m))) + +(define-command fundamental-mode (set-mark-command e #:prefix-arg arg) + #:bind-key "C-@" + #:bind-key "C-space" + (define buf (current-editor-buffer e)) + (if (eq? arg '#:prefix) + (let ((m (buffer-mark-pos buf))) + (and m (buffer-move-to! buf m))) + (buffer-mark! buf))) diff --git a/rmacs/render.rkt b/rmacs/render.rkt index ce449d7..88e4b25 100644 --- a/rmacs/render.rkt +++ b/rmacs/render.rkt @@ -27,20 +27,21 @@ ;; Ensures the given mark is sanely positioned as a top-of-window mark ;; with respect to the given cursor position. Returns the ;; top-of-window position. -(define (frame-buffer! buf window-height +(define (frame-buffer! buf available-line-count #:preferred-position-fraction [preferred-position-fraction 1/2]) (define old-top-of-window-pos (or (buffer-mark-pos buf top-of-window-mtype) 0)) - (define preferred-distance-from-bottom (ceiling (* window-height (- 1 preferred-position-fraction)))) + (define preferred-distance-from-bottom + (ceiling (* available-line-count (- 1 preferred-position-fraction)))) (let loop ((pos (buffer-findf buf newline? #:forward? #f)) (line-count 0) (top-of-window-pos old-top-of-window-pos)) (define new-top-of-window-pos (if (= line-count preferred-distance-from-bottom) pos top-of-window-pos)) (cond - [(<= pos old-top-of-window-pos) + [(= pos old-top-of-window-pos) old-top-of-window-pos] - [(= line-count window-height) - (buffer-mark! buf top-of-window-mtype #:position new-top-of-window-pos) + [(>= line-count (- available-line-count 1)) + (buffer-mark! buf new-top-of-window-pos #:mark-type top-of-window-mtype) new-top-of-window-pos] [else (loop (buffer-findf buf newline? #:forward? #f #:position (- pos 1)) @@ -59,7 +60,8 @@ #:background-color color-white)) (define (render-buffer! t b window-top window-height is-active?) - (define top-of-window-pos (frame-buffer! b window-height)) + (define available-line-count (- window-height 1)) + (define top-of-window-pos (frame-buffer! b available-line-count)) (define cursor-pos (buffer-pos b)) (tty-goto t window-top 0) (tty-body-style t is-active?) @@ -68,7 +70,7 @@ (sol-pos top-of-window-pos) (cursor-coordinates #f)) (cond - [(>= line-count (- window-height 1)) + [(>= line-count available-line-count) cursor-coordinates] [else (define eol-pos (buffer-findf b newline? #:position sol-pos)) @@ -115,11 +117,10 @@ (list (list w offset remaining)) '()))]))) -(define (render-windows! ws active-window) - (define t (stdin-tty)) +(define (render-windows! t ws active-window) (define layout (layout-windows ws (tty-rows t))) (tty-body-style t #f) - (tty-clear t) + (tty-goto t 0 0) (define active-cursor-position (for/fold [(cursor-position #f)] [(e layout)] (match-define (list w window-top window-height) e) diff --git a/rmacs/rope.rkt b/rmacs/rope.rkt index a5b55a6..5285f50 100644 --- a/rmacs/rope.rkt +++ b/rmacs/rope.rkt @@ -315,8 +315,7 @@ (define (replace-mark r0 mtype new-pos new-value) (define pos (find-mark-pos r0 mtype)) - (when (not pos) (error 'replace-mark "Mark ~a not found" mtype)) - (set-mark (clear-mark r0 mtype pos) mtype new-pos new-value)) + (set-mark (if pos (clear-mark r0 mtype pos) r0) mtype new-pos new-value)) (define (clear-all-marks r) (and r diff --git a/rmacs/topsort.rkt b/rmacs/topsort.rkt new file mode 100644 index 0000000..72d8fdf --- /dev/null +++ b/rmacs/topsort.rkt @@ -0,0 +1,54 @@ +#lang racket/base + +(provide topsort) + +(require racket/match) + +(define (topsort edges + #:comparison [comparison equal?]) + (define hash-ctor (cond [(eq? comparison equal?) hash] + [(eq? comparison eq?) hasheq] + [else (error 'topsort "Invalid comparison ~v" comparison)])) + (define-values (fwd rev) + (for/fold [(fwd (hash-ctor)) (rev (hash-ctor))] + [(edge edges)] + (match-define (list source target) edge) + (values (hash-set fwd source (hash-set (hash-ref fwd source hash-ctor) target #t)) + (hash-set rev target (hash-set (hash-ref rev target hash-ctor) source #t))))) + (define roots (for/fold [(roots (hash-ctor))] + [(source (in-hash-keys fwd))] + (if (hash-has-key? rev source) + roots + (hash-set roots source #t)))) + + (if (hash-empty? roots) + (if (and (hash-empty? fwd) (hash-empty? rev)) + '() ;; no nodes at all + #f) ;; no nodes without incoming edges -> cycle + (let/ec return + (define seen (hash-ctor)) + (define busy (hash-ctor)) + (define acc '()) + + (define (visit-nodes nodes) + (for ((n nodes)) + (when (hash-has-key? busy n) (return #f)) ;; cycle + (when (not (hash-has-key? seen n)) + (set! busy (hash-set busy n #t)) + (visit-nodes (hash-keys (hash-ref fwd n hash-ctor))) + (set! seen (hash-set seen n #t)) + (set! busy (hash-remove busy n)) + (set! acc (cons n acc))))) + + (visit-nodes (hash-keys roots)) + acc))) + +(module+ test + (require rackunit) + (check-equal? (topsort '()) '()) + (check-equal? (topsort '((1 1))) #f) + (check-equal? (topsort '((1 0) (0 1))) #f) + (check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (4 0) (0 1))) #f) + (check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (4 1) (0 1))) #f) + (check-equal? (topsort '((1 2) (1 3) (3 2) (3 4) (0 1))) '(0 1 3 4 2)) ;; others also valid + )