Much progress
This commit is contained in:
parent
c548c60bb5
commit
887155e5ec
103
rmacs/buffer.rkt
103
rmacs/buffer.rkt
|
@ -14,15 +14,25 @@
|
||||||
buffer-pos
|
buffer-pos
|
||||||
buffer-title
|
buffer-title
|
||||||
buffer-group
|
buffer-group
|
||||||
|
buffer-modeset
|
||||||
|
buffer-column
|
||||||
|
buffer-add-mode!
|
||||||
|
buffer-remove-mode!
|
||||||
|
buffer-toggle-mode!
|
||||||
buffer-size
|
buffer-size
|
||||||
buffer-move-to!
|
buffer-move-to!
|
||||||
buffer-move-by!
|
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-mark!
|
||||||
buffer-clear-mark!
|
buffer-clear-mark!
|
||||||
buffer-mark-pos
|
buffer-mark-pos
|
||||||
buffer-region-split
|
buffer-region-split
|
||||||
buffer-region
|
buffer-region
|
||||||
buffer-region-update!
|
buffer-region-update!
|
||||||
|
buffer-insert!
|
||||||
call-with-excursion
|
call-with-excursion
|
||||||
buffer-search
|
buffer-search
|
||||||
buffer-findf)
|
buffer-findf)
|
||||||
|
@ -30,6 +40,7 @@
|
||||||
(require "rope.rkt")
|
(require "rope.rkt")
|
||||||
(require "search.rkt")
|
(require "search.rkt")
|
||||||
(require "circular-list.rkt")
|
(require "circular-list.rkt")
|
||||||
|
(require "mode.rkt")
|
||||||
|
|
||||||
(require (only-in racket/string string-join))
|
(require (only-in racket/string string-join))
|
||||||
(require (only-in racket/path normalize-path))
|
(require (only-in racket/path normalize-path))
|
||||||
|
@ -44,6 +55,7 @@
|
||||||
[pos #:mutable]
|
[pos #:mutable]
|
||||||
[title #:mutable]
|
[title #:mutable]
|
||||||
[group #:mutable] ;; (Option BufferGroup)
|
[group #:mutable] ;; (Option BufferGroup)
|
||||||
|
[modeset #:mutable] ;; ModeSet
|
||||||
) #:prefab)
|
) #:prefab)
|
||||||
|
|
||||||
(define (make-buffergroup)
|
(define (make-buffergroup)
|
||||||
|
@ -55,7 +67,8 @@
|
||||||
(register-buffer! group (buffer (string->rope initial-contents)
|
(register-buffer! group (buffer (string->rope initial-contents)
|
||||||
0
|
0
|
||||||
title
|
title
|
||||||
#f)))
|
#f
|
||||||
|
kernel-modeset)))
|
||||||
|
|
||||||
(define (register-buffer! group buf)
|
(define (register-buffer! group buf)
|
||||||
(define old-group (buffer-group buf))
|
(define old-group (buffer-group buf))
|
||||||
|
@ -114,7 +127,8 @@
|
||||||
(buffer-region-update! b
|
(buffer-region-update! b
|
||||||
(lambda (_dontcare) (string->rope (file->string filename)))
|
(lambda (_dontcare) (string->rope (file->string filename)))
|
||||||
#:point 0
|
#:point 0
|
||||||
#:mark (buffer-size b))))
|
#:mark (buffer-size b))
|
||||||
|
(buffer-move-to! b 0)))
|
||||||
|
|
||||||
(define (buffer-rename! b new-title)
|
(define (buffer-rename! b new-title)
|
||||||
(if (title-exists-in-group? (buffer-group 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-size buf) (rope-size (buffer-rope buf)))
|
||||||
|
|
||||||
(define (buffer-move-to! buf pos)
|
(define (buffer-column buf)
|
||||||
(set-buffer-pos! buf (max 0 (min (buffer-size buf) pos)))
|
(- (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))
|
(buffer-seek! buf pos))
|
||||||
|
|
||||||
(define (buffer-seek! buf pos)
|
(define (buffer-seek! buf pos)
|
||||||
|
@ -146,10 +174,22 @@
|
||||||
(define (buffer-move-by! buf delta)
|
(define (buffer-move-by! buf delta)
|
||||||
(buffer-move-to! buf (+ (buffer-pos 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))
|
(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))
|
(define pos (find-mark-pos (buffer-rope buf) mtype))
|
||||||
(if pos
|
(if pos
|
||||||
(buffer-lift clear-mark buf mtype pos)
|
(buffer-lift clear-mark buf mtype pos)
|
||||||
|
@ -159,11 +199,11 @@
|
||||||
(find-mark-pos (buffer-rope buf) mtype))
|
(find-mark-pos (buffer-rope buf) mtype))
|
||||||
|
|
||||||
(define (buffer-region-split* buf pos mark)
|
(define (buffer-region-split* buf pos mark)
|
||||||
(define lo (min pos mark))
|
(define lo (clamp (min pos mark) buf))
|
||||||
(define hi (max pos mark))
|
(define hi (clamp (max pos mark) buf))
|
||||||
(define-values (l mr) (rope-split (buffer-rope buf) lo))
|
(define-values (l mr) (rope-split (buffer-rope buf) lo))
|
||||||
(define-values (m r) (rope-split mr (- hi 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
|
(define (buffer-region-split buf
|
||||||
#:point [pos (buffer-pos buf)]
|
#:point [pos (buffer-pos buf)]
|
||||||
|
@ -173,29 +213,44 @@
|
||||||
(define (buffer-region buf
|
(define (buffer-region buf
|
||||||
#:point [pos (buffer-pos buf)]
|
#:point [pos (buffer-pos buf)]
|
||||||
#:mark [mark (buffer-mark-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)
|
m)
|
||||||
|
|
||||||
(define (buffer-region-update! buf updater
|
(define (buffer-region-update! buf updater
|
||||||
#:point [pos (buffer-pos buf)]
|
#:point [pos (buffer-pos buf)]
|
||||||
#:mark [mark (buffer-mark-pos buf)])
|
#:mark [mark (buffer-mark-pos buf)])
|
||||||
(define-values (l m r) (buffer-region-split* buf pos mark))
|
(define-values (l lo old-m hi r) (buffer-region-split* buf pos mark))
|
||||||
(set-buffer-rope! buf (rope-concat (list l (updater m) r)))
|
(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)
|
buf)
|
||||||
|
|
||||||
(define (call-with-excursion buf f)
|
(define (call-with-excursion buf f)
|
||||||
(define excursion (gensym 'excursion))
|
(define excursion (gensym 'excursion))
|
||||||
(define saved-mark-type (mark-type (format "Saved mark ~a" excursion) 'right))
|
(define saved-mark-type (mark-type (format "Saved mark ~a" excursion) 'right))
|
||||||
(define saved-point-type (mark-type (format "Saved point ~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 (buffer-mark-pos buf) #:mark-type saved-mark-type)
|
||||||
(buffer-mark! buf saved-point-type #:position (buffer-pos buf))
|
(buffer-mark! buf (buffer-pos buf) #:mark-type saved-point-type)
|
||||||
(define (restore!)
|
(define (restore!)
|
||||||
(define restore-mark-pos (buffer-mark-pos buf saved-mark-type))
|
(define restore-mark-pos (buffer-mark-pos buf saved-mark-type))
|
||||||
(define restore-point-pos (buffer-mark-pos buf saved-point-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))
|
(when restore-point-pos (buffer-move-to! buf restore-point-pos))
|
||||||
(buffer-clear-mark! buf saved-mark-type)
|
(buffer-clear-mark! buf #:mark-type saved-mark-type)
|
||||||
(buffer-clear-mark! buf saved-point-type))
|
(buffer-clear-mark! buf #:mark-type saved-point-type))
|
||||||
(with-handlers [(exn? (lambda (e)
|
(with-handlers [(exn? (lambda (e)
|
||||||
(restore!)
|
(restore!)
|
||||||
(raise e)))]
|
(raise e)))]
|
||||||
|
@ -203,15 +258,19 @@
|
||||||
(restore!)
|
(restore!)
|
||||||
result))
|
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-values (l r) (rope-split (buffer-rope buf) start-pos))
|
||||||
(define delta (find-delta (if forward? r l)))
|
(define delta (find-delta (if forward? r l)))
|
||||||
(define new-pos (+ start-pos (cond [(not delta) 0] [forward? delta] [else (- delta)])))
|
(and delta
|
||||||
(when delta
|
(let ((new-pos (clamp (+ start-pos (cond [(not delta) 0]
|
||||||
|
[forward? delta]
|
||||||
|
[else (- delta (rope-size l))]))
|
||||||
|
buf)))
|
||||||
(if move?
|
(if move?
|
||||||
(buffer-move-to! buf new-pos)
|
(buffer-move-to! buf new-pos)
|
||||||
(buffer-seek! buf new-pos)))
|
(buffer-seek! buf new-pos))
|
||||||
new-pos)
|
new-pos)))
|
||||||
|
|
||||||
(define (buffer-search buf needle
|
(define (buffer-search buf needle
|
||||||
#:position [start-pos (buffer-pos buf)]
|
#:position [start-pos (buffer-pos buf)]
|
||||||
|
|
|
@ -12,6 +12,8 @@
|
||||||
tty-goto
|
tty-goto
|
||||||
tty-style
|
tty-style
|
||||||
tty-style-reset
|
tty-style-reset
|
||||||
|
tty-next-key
|
||||||
|
tty-next-key-evt
|
||||||
|
|
||||||
;; From ansi
|
;; From ansi
|
||||||
color-black
|
color-black
|
||||||
|
@ -136,3 +138,10 @@
|
||||||
(set-tty-rows! tty (position-report-row report))
|
(set-tty-rows! tty (position-report-row report))
|
||||||
(set-tty-columns! tty (position-report-column report))
|
(set-tty-columns! tty (position-report-column report))
|
||||||
tty)
|
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))))
|
||||||
|
|
|
@ -4,23 +4,38 @@
|
||||||
make-editor
|
make-editor
|
||||||
visit-file!
|
visit-file!
|
||||||
render-editor!
|
render-editor!
|
||||||
|
current-editor-buffer
|
||||||
|
current-editor-modeset
|
||||||
|
editor-invoke-command
|
||||||
|
editor-mainloop
|
||||||
|
editor-request-shutdown!
|
||||||
)
|
)
|
||||||
|
|
||||||
|
(require racket/match)
|
||||||
|
|
||||||
(require "buffer.rkt")
|
(require "buffer.rkt")
|
||||||
(require "display.rkt")
|
(require "display.rkt")
|
||||||
(require "window.rkt")
|
(require "window.rkt")
|
||||||
(require "render.rkt")
|
(require "render.rkt")
|
||||||
|
(require "mode.rkt")
|
||||||
|
(require "keys.rkt")
|
||||||
|
|
||||||
(struct editor (buffers ;; BufferGroup
|
(struct editor (buffers ;; BufferGroup
|
||||||
|
[tty #:mutable] ;; Tty
|
||||||
[windows #:mutable] ;; (List (List Window SizeSpec)), abstract window layout
|
[windows #:mutable] ;; (List (List Window SizeSpec)), abstract window layout
|
||||||
[active-window #:mutable] ;; (Option Window)
|
[active-window #:mutable] ;; (Option Window)
|
||||||
|
[running? #:mutable] ;; Boolean
|
||||||
) #:prefab)
|
) #:prefab)
|
||||||
|
|
||||||
(define (make-editor)
|
(define (make-editor [tty (stdin-tty)])
|
||||||
(define g (make-buffergroup))
|
(define g (make-buffergroup))
|
||||||
(define scratch (make-buffer g "*scratch*" #:initial-contents ";; This is the scratch buffer."))
|
(define scratch (make-buffer g "*scratch*" #:initial-contents ";; This is the scratch buffer."))
|
||||||
(define w (make-window scratch))
|
(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)
|
(define (visit-file! editor filename)
|
||||||
(set-window-buffer! (editor-active-window editor)
|
(set-window-buffer! (editor-active-window editor)
|
||||||
|
@ -28,5 +43,71 @@
|
||||||
filename)))
|
filename)))
|
||||||
|
|
||||||
(define (render-editor! editor)
|
(define (render-editor! editor)
|
||||||
(render-windows! (editor-windows editor)
|
(render-windows! (editor-tty editor)
|
||||||
|
(editor-windows editor)
|
||||||
(editor-active-window 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))
|
||||||
|
|
|
@ -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)))))
|
||||||
|
)
|
|
@ -1,19 +1,17 @@
|
||||||
#lang racket/base
|
#lang racket/base
|
||||||
|
|
||||||
(require "editor.rkt")
|
|
||||||
(require "render.rkt")
|
|
||||||
(require racket/match)
|
(require racket/match)
|
||||||
|
|
||||||
|
(require "editor.rkt")
|
||||||
|
(require "buffer.rkt")
|
||||||
|
(require "mode/fundamental.rkt")
|
||||||
|
|
||||||
(define (main)
|
(define (main)
|
||||||
(with-handlers ([exn? (lambda (e)
|
|
||||||
(local-require ansi)
|
|
||||||
(tty-restore!)
|
|
||||||
(raise e))])
|
|
||||||
(define e (make-editor))
|
(define e (make-editor))
|
||||||
(visit-file! e (build-path (collection-file-path "main.rkt" "rmacs")
|
(visit-file! e (build-path (collection-file-path "main.rkt" "rmacs")
|
||||||
'up 'up "doc" "xterm_controls.txt"))
|
'up 'up "doc" "xterm_controls.txt"))
|
||||||
(render-editor! e))
|
(buffer-add-mode! (current-editor-buffer e) fundamental-mode)
|
||||||
(sleep 2))
|
(editor-mainloop e))
|
||||||
|
|
||||||
(module+ main
|
(module+ main
|
||||||
(void (main)))
|
(void (main)))
|
||||||
|
|
|
@ -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))])))
|
|
@ -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 "<right>"
|
||||||
|
(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 "<left>"
|
||||||
|
(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 "<down>"
|
||||||
|
(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 "<up>"
|
||||||
|
(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 "<end>"
|
||||||
|
(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 "<home>"
|
||||||
|
(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 "<backspace>"
|
||||||
|
#: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 "<delete>"
|
||||||
|
#: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-<home>"
|
||||||
|
#:bind-key "<begin>"
|
||||||
|
(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-<end>"
|
||||||
|
(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)))
|
|
@ -27,20 +27,21 @@
|
||||||
;; Ensures the given mark is sanely positioned as a top-of-window mark
|
;; Ensures the given mark is sanely positioned as a top-of-window mark
|
||||||
;; with respect to the given cursor position. Returns the
|
;; with respect to the given cursor position. Returns the
|
||||||
;; top-of-window position.
|
;; 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])
|
#: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 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))
|
(let loop ((pos (buffer-findf buf newline? #:forward? #f))
|
||||||
(line-count 0)
|
(line-count 0)
|
||||||
(top-of-window-pos old-top-of-window-pos))
|
(top-of-window-pos old-top-of-window-pos))
|
||||||
(define new-top-of-window-pos
|
(define new-top-of-window-pos
|
||||||
(if (= line-count preferred-distance-from-bottom) pos top-of-window-pos))
|
(if (= line-count preferred-distance-from-bottom) pos top-of-window-pos))
|
||||||
(cond
|
(cond
|
||||||
[(<= pos old-top-of-window-pos)
|
[(= pos old-top-of-window-pos)
|
||||||
old-top-of-window-pos]
|
old-top-of-window-pos]
|
||||||
[(= line-count window-height)
|
[(>= line-count (- available-line-count 1))
|
||||||
(buffer-mark! buf top-of-window-mtype #:position new-top-of-window-pos)
|
(buffer-mark! buf new-top-of-window-pos #:mark-type top-of-window-mtype)
|
||||||
new-top-of-window-pos]
|
new-top-of-window-pos]
|
||||||
[else
|
[else
|
||||||
(loop (buffer-findf buf newline? #:forward? #f #:position (- pos 1))
|
(loop (buffer-findf buf newline? #:forward? #f #:position (- pos 1))
|
||||||
|
@ -59,7 +60,8 @@
|
||||||
#:background-color color-white))
|
#:background-color color-white))
|
||||||
|
|
||||||
(define (render-buffer! t b window-top window-height is-active?)
|
(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))
|
(define cursor-pos (buffer-pos b))
|
||||||
(tty-goto t window-top 0)
|
(tty-goto t window-top 0)
|
||||||
(tty-body-style t is-active?)
|
(tty-body-style t is-active?)
|
||||||
|
@ -68,7 +70,7 @@
|
||||||
(sol-pos top-of-window-pos)
|
(sol-pos top-of-window-pos)
|
||||||
(cursor-coordinates #f))
|
(cursor-coordinates #f))
|
||||||
(cond
|
(cond
|
||||||
[(>= line-count (- window-height 1))
|
[(>= line-count available-line-count)
|
||||||
cursor-coordinates]
|
cursor-coordinates]
|
||||||
[else
|
[else
|
||||||
(define eol-pos (buffer-findf b newline? #:position sol-pos))
|
(define eol-pos (buffer-findf b newline? #:position sol-pos))
|
||||||
|
@ -115,11 +117,10 @@
|
||||||
(list (list w offset remaining))
|
(list (list w offset remaining))
|
||||||
'()))])))
|
'()))])))
|
||||||
|
|
||||||
(define (render-windows! ws active-window)
|
(define (render-windows! t ws active-window)
|
||||||
(define t (stdin-tty))
|
|
||||||
(define layout (layout-windows ws (tty-rows t)))
|
(define layout (layout-windows ws (tty-rows t)))
|
||||||
(tty-body-style t #f)
|
(tty-body-style t #f)
|
||||||
(tty-clear t)
|
(tty-goto t 0 0)
|
||||||
(define active-cursor-position
|
(define active-cursor-position
|
||||||
(for/fold [(cursor-position #f)] [(e layout)]
|
(for/fold [(cursor-position #f)] [(e layout)]
|
||||||
(match-define (list w window-top window-height) e)
|
(match-define (list w window-top window-height) e)
|
||||||
|
|
|
@ -315,8 +315,7 @@
|
||||||
|
|
||||||
(define (replace-mark r0 mtype new-pos new-value)
|
(define (replace-mark r0 mtype new-pos new-value)
|
||||||
(define pos (find-mark-pos r0 mtype))
|
(define pos (find-mark-pos r0 mtype))
|
||||||
(when (not pos) (error 'replace-mark "Mark ~a not found" mtype))
|
(set-mark (if pos (clear-mark r0 mtype pos) r0) mtype new-pos new-value))
|
||||||
(set-mark (clear-mark r0 mtype pos) mtype new-pos new-value))
|
|
||||||
|
|
||||||
(define (clear-all-marks r)
|
(define (clear-all-marks r)
|
||||||
(and r
|
(and r
|
||||||
|
|
|
@ -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
|
||||||
|
)
|
Loading…
Reference in New Issue