From 0c559238daaaaff90ed6ac5f048c8214a890a7ec Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sat, 27 Dec 2014 18:16:28 -0500 Subject: [PATCH] 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 --- rmacs/TODO | 3 - rmacs/api.rkt | 14 +++++ rmacs/buffer.rkt | 120 ++++++++++++++++++++++++++++++++----- rmacs/editor.rkt | 13 ++-- rmacs/keys.rkt | 9 ++- rmacs/main.rkt | 12 ++-- rmacs/mode.rkt | 60 ++----------------- rmacs/mode/fundamental.rkt | 9 +-- rmacs/window.rkt | 6 ++ 9 files changed, 154 insertions(+), 92 deletions(-) create mode 100644 rmacs/api.rkt diff --git a/rmacs/TODO b/rmacs/TODO index 6fc754a..7b45a30 100644 --- a/rmacs/TODO +++ b/rmacs/TODO @@ -4,9 +4,6 @@ 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. Catch and handle SIGWINCH. diff --git a/rmacs/api.rkt b/rmacs/api.rkt new file mode 100644 index 0000000..fc4a82a --- /dev/null +++ b/rmacs/api.rkt @@ -0,0 +1,14 @@ +#lang racket/base +;; API for writing modes/commands/etc. + +(require "mode.rkt") +(require "editor.rkt") +(require "buffer.rkt") +(require "keys.rkt") +(require "rope.rkt") + +(provide (all-from-out "mode.rkt" + "editor.rkt" + "buffer.rkt" + "keys.rkt" + "rope.rkt")) diff --git a/rmacs/buffer.rkt b/rmacs/buffer.rkt index 4939e8b..37e72b5 100644 --- a/rmacs/buffer.rkt +++ b/rmacs/buffer.rkt @@ -21,7 +21,6 @@ buffer-modeset buffer-column buffer-apply-modeset! - invoke-command buffer-add-mode! buffer-remove-mode! buffer-toggle-mode! @@ -42,7 +41,25 @@ buffer-replace-contents! call-with-excursion buffer-search - buffer-findf) + buffer-findf + + command? + command-selector + command-buffer + command-window + command-editor + (rename-out [make-command command]) + invoke + + define-key + define-command) + +(require racket/match) +(require (for-syntax syntax/parse)) +(require (for-syntax racket/base)) +(require (only-in racket/string string-join)) +(require (only-in racket/path normalize-path)) +(require (only-in racket/file file->string)) (require "rope.rkt") (require "search.rkt") @@ -50,10 +67,6 @@ (require "mode.rkt") (require "keys.rkt") -(require (only-in racket/string string-join)) -(require (only-in racket/path normalize-path)) -(require (only-in racket/file file->string)) - (define main-mark-type (mark-type "main" 'right)) (struct buffergroup ([members #:mutable] ;; (CircularList Buffer) @@ -67,6 +80,14 @@ [modeset #:mutable] ;; ModeSet ) #:prefab) +(struct command (selector ;; Symbol + buffer ;; Buffer + window ;; (Option Window) + editor ;; Editor + keyseq ;; (Option Keyseq) + prefix-arg ;; Any + ) #:prefab) + (define (make-buffergroup) (buffergroup circular-empty #f)) @@ -182,16 +203,6 @@ (define (buffer-apply-modeset! buf modeset) (set-buffer-modeset! buf modeset)) -(define (invoke-command selector buf - #:keyseq [keyseq #f] - #:prefix-arg [prefix-arg '#:default]) - (define cmd (modeset-lookup-command (buffer-modeset buf) selector)) - (when (not cmd) - (error 'invoke-command "Unhandled command ~a (key sequence: ~a)" - selector - (if keyseq (keyseq->keyspec keyseq) "N/A"))) - (cmd buf prefix-arg keyseq)) - (define (buffer-add-mode! buf mode) (set-buffer-modeset! buf (modeset-add-mode (buffer-modeset buf) mode))) (define (buffer-remove-mode! buf mode) @@ -332,3 +343,80 @@ (define new-rope (apply f (buffer-rope buf) args)) (set-buffer-rope! buf new-rope) buf) + +;;--------------------------------------------------------------------------- + +(define (make-command selector buffer-or-command + #:window [window #f] + #:editor [editor #f] + #:keyseq [keyseq #f] + #:prefix-arg [prefix-arg '#:default]) + (define buffer (cond + [(buffer? buffer-or-command) buffer-or-command] + [(command? buffer-or-command) (command-buffer buffer-or-command)])) + (command selector buffer window (or editor (buffer-editor buffer)) keyseq prefix-arg)) + +(define (invoke cmd) + (match-define (command selector buf _ _ keyseq _) cmd) + (define handler (modeset-lookup-command (buffer-modeset buf) selector)) + (when (not handler) + (error 'invoke "Unhandled command ~a (key sequence: ~a)" + selector + (if keyseq (keyseq->keyspec keyseq) "N/A"))) + (handler cmd)) + +(define-syntax-rule (define-key mode-exp keyspec-exp command-symbol) + (void (mode-keymap-bind! mode-exp keyspec-exp 'command-symbol))) + +(define-syntax define-command + (lambda (stx) + (syntax-parse stx + [(_ mode-exp + (selector buffer + (~or (~optional (~seq #:next-method next-method) + #:defaults ([next-method #'nm]) + #:name "#:next-method") + (~optional (~seq #:command cmd) + #:defaults ([cmd #'cmd]) + #:name "#:command") + (~optional (~seq #:selector self-selector) + #:defaults ([self-selector #'self]) + #:name "#:selector") + (~optional (~seq #:window window) + #:defaults ([window #'win]) + #:name "#:window") + (~optional (~seq #:editor editor) + #:defaults ([editor #'ed]) + #:name "#:editor") + (~optional (~seq #:keyseq keyseq) + #:defaults ([keyseq #'keyseq]) + #:name "#:keyseq") + (~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")) + ...) + (~seq #:bind-key bind-keyspec-exps) ... + body ...) + #`(let ((mode mode-exp)) + (mode-define-command! mode + 'selector + (lambda (cmd next-method) + (match-define (command self-selector + buffer + window + editor + keyseq + prefix-arg) cmd) + (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/editor.rkt b/rmacs/editor.rkt index 66d80c8..fce1586 100644 --- a/rmacs/editor.rkt +++ b/rmacs/editor.rkt @@ -4,6 +4,7 @@ make-editor visit-file! render-editor! + editor-command editor-active-buffer editor-active-modeset editor-mainloop @@ -80,6 +81,11 @@ (define b (editor-active-buffer editor)) (and b (buffer-modeset b))) +(define (editor-command selector editor + #:keyseq [keyseq #f] + #:prefix-arg [prefix-arg '#:default]) + (window-command selector (editor-active-window editor) #:keyseq keyseq #:prefix-arg prefix-arg)) + (define (root-keyseq-handler editor) (modeset-keyseq-handler (editor-active-modeset editor))) @@ -126,8 +132,7 @@ [else (match (handler editor input) [(unbound-key-sequence) - (if (invoke-command 'unbound-key-sequence (editor-active-buffer editor) - #:keyseq total-keyseq) + (if (invoke (editor-command 'unbound-key-sequence editor #:keyseq total-keyseq)) (loop '() '() (root-keyseq-handler editor) (request-repaint)) (error 'editor-mainloop "Unbound key sequence: ~a" (keyseq->keyspec total-keyseq)))] @@ -139,9 +144,7 @@ (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) + (invoke (editor-command selector editor #:keyseq accepted-input #:prefix-arg prefix-arg)) (loop '() remaining-input (root-keyseq-handler editor) (request-repaint))])])))) (define (editor-request-shutdown! editor) diff --git a/rmacs/keys.rkt b/rmacs/keys.rkt index a9ef78d..20c02ce 100644 --- a/rmacs/keys.rkt +++ b/rmacs/keys.rkt @@ -10,7 +10,12 @@ keymap-update keymap-bind keymap-unbind - keymap-lookup) + keymap-lookup + + ;; From ansi/lcd-terminal + (struct-out key) + (struct-out unknown-escape-sequence) + add-modifier) (require racket/set) (require racket/match) @@ -113,7 +118,7 @@ (format-modifiers updated-modifiers str)])) (define (keyseq->keyspec keyseq) - (string-join (map key->keyspec keyseq) " ")) + (and keyseq (string-join (map key->keyspec keyseq) " "))) ;;--------------------------------------------------------------------------- ;; Keymaps diff --git a/rmacs/main.rkt b/rmacs/main.rkt index f968562..dae8d58 100644 --- a/rmacs/main.rkt +++ b/rmacs/main.rkt @@ -1,5 +1,7 @@ #lang racket/base +(provide rmacs) + (require racket/match) (require "editor.rkt") @@ -7,17 +9,19 @@ (require "mode.rkt") (require "mode/fundamental.rkt") -(define (main) +(define (rmacs #:initial-files [initial-files '()]) (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")) + (for ((file initial-files)) (visit-file! e file)) (editor-mainloop e)) (module+ main (require racket/trace) (current-trace-notify (lambda (s) (log-info "TRACE: ~a" s))) - (void (main)) + (void + (rmacs #:initial-files (list + (build-path (collection-file-path "main.rkt" "rmacs") + 'up 'up "doc" "xterm_controls.txt")))) ;; (require profile) ;; (require ansi) ;; (void (profile-thunk (lambda () (begin0 (main) diff --git a/rmacs/mode.rkt b/rmacs/mode.rkt index 1f59db8..120f2de 100644 --- a/rmacs/mode.rkt +++ b/rmacs/mode.rkt @@ -25,16 +25,11 @@ modeset-lookup-command kernel-mode - kernel-modeset - - define-key - define-command) + kernel-modeset) (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") @@ -195,14 +190,11 @@ [(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]) + (lambda (cmd) + (handler cmd + (lambda ([cmd cmd]) (define next-method (search rest)) - (when next-method (next-method e prefix-arg ks))) - selector - prefix-arg - ks)) + (when next-method (next-method cmd))))) (search rest))]))) (define kernel-mode @@ -212,45 +204,3 @@ (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 buffer - (~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 (buffer 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 index b987a50..f51b0ca 100644 --- a/rmacs/mode/fundamental.rkt +++ b/rmacs/mode/fundamental.rkt @@ -4,12 +4,7 @@ (require racket/set) (require racket/match) -(require ansi/lcd-terminal) -(require "../mode.rkt") -(require "../editor.rkt") -(require "../buffer.rkt") -(require "../keys.rkt") -(require "../rope.rkt") +(require "../api.rkt") (define fundamental-mode (make-mode "fundamental")) @@ -20,7 +15,7 @@ [_ #f])) (define-command fundamental-mode (unbound-key-sequence buf #:keyseq keyseq) - (invoke-command 'self-insert-command buf #:keyseq keyseq)) + (invoke (command 'self-insert-command buf #:keyseq keyseq))) (define-key fundamental-mode (list "C-q" '#:default) self-insert-command) diff --git a/rmacs/window.rkt b/rmacs/window.rkt index b3f60b4..7602499 100644 --- a/rmacs/window.rkt +++ b/rmacs/window.rkt @@ -5,6 +5,7 @@ (struct-out relative-size) make-window window-split + window-command ) (require racket/match) @@ -38,3 +39,8 @@ (define new-size (if proportional? (cadr e) (scale-size (cadr e)))) (list (list w new-size) (list (make-window (window-buffer w)) new-size))))) + +(define (window-command selector window + #:keyseq [keyseq #f] + #:prefix-arg [prefix-arg '#:default]) + (command selector (window-buffer window) #:window window #:keyseq keyseq #:prefix-arg prefix-arg))