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

More progress

This commit is contained in:
Tony Garnock-Jones 2014-12-23 11:09:22 -05:00
parent 887155e5ec
commit fe7185b321
8 changed files with 171 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

60
rmacs/buffer.rkt
View File

@ -6,6 +6,7 @@
make-buffer
register-buffer!
lookup-buffer
unused-buffer-title
file->buffer
buffer-rename!
buffer-reorder!
@ -16,6 +17,7 @@
buffer-group
buffer-modeset
buffer-column
buffer-apply-modeset!
buffer-add-mode!
buffer-remove-mode!
buffer-toggle-mode!
@ -33,6 +35,7 @@
buffer-region
buffer-region-update!
buffer-insert!
buffer-replace-contents!
call-with-excursion
buffer-search
buffer-findf)
@ -61,10 +64,17 @@
(define (make-buffergroup)
(buffergroup circular-empty))
(define (initial-contents-rope initial-contents)
(cond
[(string? initial-contents) (string->rope initial-contents)]
[(rope? initial-contents) initial-contents]
[(procedure? initial-contents) (initial-contents-rope (initial-contents))]
[else (error 'initial-contents-rope "Invalid initial-contents: ~v" initial-contents)]))
(define (make-buffer group ;; (Option BufferGroup)
title ;; String
#:initial-contents [initial-contents ""])
(register-buffer! group (buffer (string->rope initial-contents)
(register-buffer! group (buffer (initial-contents-rope initial-contents)
0
title
#f
@ -98,36 +108,36 @@
(define (title-exists-in-group? group title)
(and (title->buffer* group title) #t))
(define (unused-buffer-title group context-pieces)
(define primary-piece (if (null? context-pieces) "*anonymous*" (car context-pieces)))
(define uniquifiers (if (null? context-pieces) '() (cdr context-pieces)))
(let search ((used '()) (remaining uniquifiers))
(define candidate
(if (null? used)
primary-piece
(format "~a<~a>" primary-piece (string-join used "/"))))
(if (title-exists-in-group? group candidate)
(if (pair? remaining)
(search (cons (car remaining) used) (cdr remaining))
(let search ((counter 2))
(define candidate (format "~a<~a>" primary-piece counter))
(if (title-exists-in-group? group candidate)
(search (+ counter 1))
candidate)))
candidate)))
;; (Option Group) Path -> String
(define (filename->unique-buffer-title group filename)
(define pieces (reverse (map path->string (explode-path filename))))
(define primary-piece (car pieces))
(define uniquifiers (cdr pieces))
(if (not group)
primary-piece
(let search ((used '()) (remaining uniquifiers))
(define candidate
(if (null? used)
primary-piece
(format "~a<~a>" primary-piece (string-join used "/"))))
(if (title-exists-in-group? group candidate)
(if (pair? remaining)
(search (cons (car remaining) used) (cdr remaining))
(let search ((counter 2))
(define candidate (format "~a<~a>" primary-piece counter))
(if (title-exists-in-group? group candidate)
(search (+ counter 1))
candidate)))
candidate))))
(car pieces)
(unused-buffer-title group pieces)))
(define (file->buffer group filename)
(let* ((filename (normalize-path (simplify-path filename)))
(title (filename->unique-buffer-title group filename))
(b (make-buffer group title)))
(buffer-region-update! b
(lambda (_dontcare) (string->rope (file->string filename)))
#:point 0
#:mark (buffer-size b))
(buffer-replace-contents! b (string->rope (file->string filename)))
(buffer-move-to! b 0)))
(define (buffer-rename! b new-title)
@ -153,6 +163,9 @@
(define (buffer-column buf)
(- (buffer-pos buf) (buffer-start-of-line buf)))
(define (buffer-apply-modeset! buf modeset)
(set-buffer-modeset! buf modeset))
(define (buffer-add-mode! buf mode)
(set-buffer-modeset! buf (modeset-add-mode (buffer-modeset buf) mode)))
(define (buffer-remove-mode! buf mode)
@ -238,6 +251,9 @@
(set-buffer-pos! buf (+ (buffer-pos buf) (rope-size content-rope))))
buf)
(define (buffer-replace-contents! buf content-rope)
(buffer-region-update! buf (lambda (_dontcare) content-rope) #:point 0 #:mark (buffer-size buf)))
(define (call-with-excursion buf f)
(define excursion (gensym 'excursion))
(define saved-mark-type (mark-type (format "Saved mark ~a" excursion) 'right))

9
rmacs/display.rkt
View File

@ -25,6 +25,7 @@
color-cyan
color-white)
(require racket/set)
(require racket/match)
(require ansi)
@ -140,7 +141,13 @@
tty)
(define (tty-next-key tty)
(lex-lcd-input (tty-input tty)))
(define k (lex-lcd-input (tty-input tty)))
(if (equal? k (key #\[ (set 'control))) ;; ESC
(or (sync/timeout 0.5
(handle-evt (tty-next-key-evt tty)
(lambda (k) (add-modifier 'meta k))))
k)
k))
(define (tty-next-key-evt tty)
(handle-evt (tty-input tty)

99
rmacs/editor.rkt
View File

@ -4,8 +4,8 @@
make-editor
visit-file!
render-editor!
current-editor-buffer
current-editor-modeset
editor-active-buffer
editor-active-modeset
editor-invoke-command
editor-mainloop
editor-request-shutdown!
@ -19,89 +19,122 @@
(require "render.rkt")
(require "mode.rkt")
(require "keys.rkt")
(require "rope.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
[default-modeset #:mutable] ;; ModeSet
) #:prefab)
(define (make-editor [tty (stdin-tty)])
(define (make-editor #:tty [tty (stdin-tty)]
#:default-modeset [default-modeset (make-modeset)])
(define g (make-buffergroup))
(define scratch (make-buffer g "*scratch*" #:initial-contents ";; This is the scratch buffer."))
(define w (make-window scratch))
(editor g
tty
(list (list w (relative-size 1)))
w
#f))
(define e (editor g
tty
(list (list w (relative-size 1)))
w
#f
default-modeset))
(configure-fresh-buffer! e scratch)
e)
(define (configure-fresh-buffer! editor buffer)
(buffer-apply-modeset! buffer (editor-default-modeset editor))
buffer)
(define (find-buffer editor [title0 #f] #:initial-contents [initial-contents ""])
(define g (editor-buffers editor))
(define title (or title0 (unused-buffer-title g '())))
(or (lookup-buffer g title)
(configure-fresh-buffer! editor (make-buffer g title #:initial-contents initial-contents))))
(define (open-window editor buffer
#:size [size (relative-size 1)]
#:activate? [activate? #t])
(define w (make-window buffer))
(set-editor-windows! editor (append (editor-windows editor) (list (list w size))))
(when activate? (set-editor-active-window! editor w))
w)
(define (visit-file! editor filename)
(set-window-buffer! (editor-active-window editor)
(file->buffer (editor-buffers editor)
filename)))
(configure-fresh-buffer! editor
(file->buffer (editor-buffers editor) filename))))
(define (render-editor! editor)
(render-windows! (editor-tty editor)
(editor-windows editor)
(editor-active-window editor)))
(define (current-editor-buffer editor)
(define (editor-active-buffer editor)
(define w (editor-active-window editor))
(and w (window-buffer w)))
(define (current-editor-modeset editor)
(define b (current-editor-buffer editor))
(define (editor-active-modeset editor)
(define b (editor-active-buffer editor))
(and b (buffer-modeset b)))
(define (root-keyseq-handler editor)
(modeset-keyseq-handler (current-editor-modeset editor)))
(modeset-keyseq-handler (editor-active-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))
(define cmd (modeset-lookup-command (editor-active-modeset editor) selector))
(when (not cmd)
(error 'main "Unhandled command ~a (key sequence: ~a)"
(error 'editor-invoke-command "Unhandled command ~a (key sequence: ~a)"
selector
(keyseq->keyspec keyseq)))
(cmd editor prefix-arg keyseq))
(define (open-debugger editor exc)
(local-require (only-in web-server/private/util exn->string))
(define error-report (exn->string exc))
(log-error "Exception:\n~a\n" error-report)
(define b (find-buffer editor "*Error*"))
(buffer-replace-contents! b (string->rope error-report))
(open-window editor b))
(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 '())
(with-handlers* ([exn? (lambda (exc)
(set-editor-running?! editor #f)
(open-debugger editor exc)
(editor-mainloop editor))])
(let loop ((total-keyseq '())
(input '())
(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)
(define new-input (list new-key))
(loop (append total-keyseq new-input) new-input next-handler))))))
(if (null? input)
(wait-for-input handler)
(match (handler editor keys)
(match (handler editor input)
[(unbound-key-sequence)
(editor-invoke-command 'unbound-key-sequence editor #:keyseq keys)
(loop '() (root-keyseq-handler editor))]
(if (editor-invoke-command 'unbound-key-sequence editor #:keyseq total-keyseq)
(loop '() '() (root-keyseq-handler editor))
(error 'editor-mainloop "Unbound key sequence: ~a"
(keyseq->keyspec total-keyseq)))]
[(incomplete-key-sequence next-handler)
(wait-for-input next-handler)]
[(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)
(let remove-tail ((keyseq total-keyseq))
(if (equal? keyseq remaining-input)
'()
(cons (car input) (loop (cdr input))))))
(cons (car keyseq) (remove-tail (cdr keyseq))))))
(editor-invoke-command selector editor #:keyseq accepted-input #:prefix-arg prefix-arg)
(loop remaining-input (root-keyseq-handler editor))])))))
(loop '() remaining-input (root-keyseq-handler editor))])))))
(define (editor-request-shutdown! editor)
(set-editor-running?! editor #f))

3
rmacs/keys.rkt
View File

@ -107,7 +107,8 @@
(values "ESC" (set-remove modifiers 'control))]
[(? char? c)
(define s (format "~v" c))
(values (substring s 2 (string-length s)) modifiers)]))
(define maybe-downcase (if (set-member? modifiers 'control) string-downcase values))
(values (maybe-downcase (substring s 2 (string-length s))) modifiers)]))
(format-modifiers updated-modifiers str)]))
(define (keyseq->keyspec keyseq)

5
rmacs/main.rkt
View File

@ -4,13 +4,14 @@
(require "editor.rkt")
(require "buffer.rkt")
(require "mode.rkt")
(require "mode/fundamental.rkt")
(define (main)
(define e (make-editor))
(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"))
(buffer-add-mode! (current-editor-buffer e) fundamental-mode)
(editor-mainloop e))
(module+ main

2
rmacs/mode.rkt
View File

@ -5,7 +5,6 @@
(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
@ -57,7 +56,6 @@
(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)

41
rmacs/mode/fundamental.rkt
View File

@ -2,6 +2,8 @@
(provide fundamental-mode)
(require racket/set)
(require racket/match)
(require ansi/lcd-terminal)
(require "../mode.rkt")
(require "../editor.rkt")
@ -11,15 +13,12 @@
(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)))))
(log-info "self-insert-command ~a" (keyseq->keyspec keyseq))
(match keyseq
[(list (key (? char? ch) modifiers)) #:when (set-empty? (set-remove modifiers 'shift))
(buffer-insert! (editor-active-buffer e) (string->rope (string ch)))]
[_ #f]))
(define-command fundamental-mode (unbound-key-sequence e #:keyseq keyseq)
(editor-invoke-command 'self-insert-command e #:keyseq keyseq))
@ -29,7 +28,7 @@
(define-command fundamental-mode (newline e)
#:bind-key "C-m"
#:bind-key "C-j"
(buffer-insert! (current-editor-buffer e) (string->rope "\n")))
(buffer-insert! (editor-active-buffer e) (string->rope "\n")))
(define (move-forward-n-lines buf count)
(for ((i count))
@ -49,17 +48,17 @@
(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))
(buffer-move-by! (editor-active-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)))
(buffer-move-by! (editor-active-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 buf (editor-active-buffer e))
(define col (buffer-column buf))
(move-forward-n-lines buf count)
(move-to-column buf col))
@ -67,7 +66,7 @@
(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 buf (editor-active-buffer e))
(define col (buffer-column buf))
(move-backward-n-lines buf count)
(move-to-column buf col))
@ -75,21 +74,21 @@
(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))
(define buf (editor-active-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))
(define buf (editor-active-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))
(define buf (editor-active-buffer e))
(buffer-region-update! buf
(lambda (_deleted) (empty-rope))
#:mark (- (buffer-pos buf) count)))
@ -97,7 +96,7 @@
(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))
(define buf (editor-active-buffer e))
(buffer-region-update! buf
(lambda (_deleted) (empty-rope))
#:mark (+ (buffer-pos buf) count)))
@ -106,20 +105,20 @@
#:bind-key "M-<"
#:bind-key "C-<home>"
#:bind-key "<begin>"
(define buf (current-editor-buffer e))
(define buf (editor-active-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))
(define buf (editor-active-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 buf (editor-active-buffer e))
(define m (buffer-mark-pos buf))
(when m
(define p (buffer-pos buf))
@ -129,7 +128,7 @@
(define-command fundamental-mode (set-mark-command e #:prefix-arg arg)
#:bind-key "C-@"
#:bind-key "C-space"
(define buf (current-editor-buffer e))
(define buf (editor-active-buffer e))
(if (eq? arg '#:prefix)
(let ((m (buffer-mark-pos buf)))
(and m (buffer-move-to! buf m)))

38
rmacs/render.rkt
View File

@ -59,6 +59,35 @@
#:foreground-color color-black
#:background-color color-white))
(define (format-line line window-width cursor-input-pos)
(let loop ((chars (string->list line))
(remaining-width window-width)
(cursor-input-pos cursor-input-pos)
(acc-rev '())
(cursor-offset (if (zero? cursor-input-pos) 0 #f)))
(define (finish) (values (list->string (reverse acc-rev)) cursor-offset))
(match chars
['() (finish)]
[(cons c rest)
(define (emit str)
(define needed (string-length str))
(if (>= remaining-width needed)
(loop rest
(- remaining-width needed)
(- cursor-input-pos 1)
(append (reverse (string->list str)) acc-rev)
(if (zero? cursor-input-pos)
(length acc-rev)
cursor-offset))
(finish)))
(match c
[#\tab
(emit (make-string (- 8 (modulo (length acc-rev) 8)) #\space))]
[(? char-iso-control?)
(emit (format "[~x]" (char->integer c)))]
[_
(emit (string c))])])))
(define (render-buffer! t b window-top window-height is-active?)
(define available-line-count (- window-height 1))
(define top-of-window-pos (frame-buffer! b available-line-count))
@ -75,14 +104,15 @@
[else
(define eol-pos (buffer-findf b newline? #:position sol-pos))
(define line (rope->string (buffer-region b #:point eol-pos #:mark sol-pos)))
(tty-display t line)
(define-values (formatted-line cursor-offset)
(format-line line (tty-columns t) (- cursor-pos sol-pos)))
(tty-display t formatted-line)
(tty-clear-to-eol t)
(tty-newline t)
(loop (+ line-count 1)
(+ eol-pos 1)
(if (<= sol-pos cursor-pos eol-pos)
(list (+ line-count window-top)
(- cursor-pos sol-pos))
(if cursor-offset
(list (+ line-count window-top) cursor-offset)
cursor-coordinates))])))
(tty-statusline-style t is-active?)
(tty-display t (if is-active? "== " "-- ") (buffer-title b) " ")