misc-deps
/
racket-ansi
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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
This commit is contained in:
Tony Garnock-Jones 2014-12-27 18:16:28 -05:00
parent 04f7da73e2
commit 0c559238da
9 changed files with 154 additions and 92 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
rmacs/TODO
View File

@ -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.

14
rmacs/api.rkt Normal file
View File

@ -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"))

120
rmacs/buffer.rkt
View File

@ -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))])))

13
rmacs/editor.rkt
View File

@ -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)

9
rmacs/keys.rkt
View File

@ -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

12
rmacs/main.rkt
View File

@ -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)

60
rmacs/mode.rkt
View File

@ -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))])))

9
rmacs/mode/fundamental.rkt
View File

@ -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)

6
rmacs/window.rkt
View File

@ -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))