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

Give windows each their own top/point/mark marks. Basic window split/close/switch commands.

This commit is contained in:
Tony Garnock-Jones 2014-12-27 23:59:12 -05:00
parent a512da0d7b
commit 1cdf0900b6
9 changed files with 356 additions and 218 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
rmacs/TODO
View File

@ -1,6 +1,6 @@
Make it reloadable
Windows need their own top-of-window-mtype and point location
The status line isn't cleared away when you C-x 2.
Preserve column on up/down better. This includes dealing with tab expansion

4
rmacs/api.rkt
View File

@ -6,9 +6,11 @@
(require "buffer.rkt")
(require "keys.rkt")
(require "rope.rkt")
(require "window.rkt")
(provide (all-from-out "mode.rkt"
"editor.rkt"
"buffer.rkt"
"keys.rkt"
"rope.rkt"))
"rope.rkt"
"window.rkt"))

195
rmacs/buffer.rkt
View File

@ -1,8 +1,8 @@
#lang racket/base
(provide make-buffergroup
(provide (struct-out buffer-mark-type)
make-buffergroup
initialize-buffergroup!
main-mark-type
buffer?
make-buffer
register-buffer!
@ -13,7 +13,6 @@
buffer-reorder!
buffer-next
buffer-prev
buffer-pos
buffer-title
buffer-rope
buffer-group
@ -25,21 +24,23 @@
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-types
buffer-mark*
buffer-mark
buffer-mark-pos*
buffer-mark-pos
buffer-mark!
buffer-clear-mark!
buffer-mark-pos
buffer-move-mark!
buffer-move-mark-to-start-of-line!
buffer-move-mark-to-end-of-line!
buffer-region-split
buffer-region
buffer-region-update!
buffer-insert!
buffer-replace-contents!
call-with-excursion
buffer-search
buffer-findf
@ -67,14 +68,16 @@
(require "mode.rkt")
(require "keys.rkt")
(define main-mark-type (mark-type "main" 'right))
(struct buffer-mark-type (kind ;; Symbol
window-id ;; Symbol
preserve? ;; Boolean
) #:prefab)
(struct buffergroup ([members #:mutable] ;; (CircularList Buffer)
[editor #:mutable] ;; (Option Editor), for bidirectional editor/group linkage
) #:prefab)
(struct buffer ([rope #:mutable]
[pos #:mutable]
[title #:mutable]
[group #:mutable] ;; (Option BufferGroup)
[modeset #:mutable] ;; ModeSet
@ -108,7 +111,6 @@
title ;; String
#:initial-contents [initial-contents ""])
(register-buffer! group (buffer (initial-contents-rope initial-contents)
0
title
#f
kernel-modeset)))
@ -129,7 +131,8 @@
(define (title->buffer* group title)
(and group
(circular-list-memf (lambda (b) (equal? (buffer-title b) title)) (buffergroup-members group))))
(circular-list-memf (lambda (b) (equal? (buffer-title b) title))
(buffergroup-members group))))
(define (buffer->buffer* group b)
(and group
@ -170,8 +173,7 @@
(let* ((filename (normalize-path (simplify-path filename)))
(title (filename->unique-buffer-title group filename))
(b (make-buffer group title)))
(buffer-replace-contents! b (string->rope (file->string filename)))
(buffer-move-to! b 0)))
(buffer-replace-contents! b (string->rope (file->string filename)))))
(define (buffer-rename! b new-title)
(if (title-exists-in-group? (buffer-group b) new-title)
@ -197,8 +199,10 @@
(define g (buffer-group b))
(and g (buffergroup-editor g)))
(define (buffer-column buf)
(- (buffer-pos buf) (buffer-start-of-line buf)))
(define (buffer-column buf pos-or-mtype)
;; TODO: count actual columns!
(define pos (->pos buf pos-or-mtype 'buffer-column))
(- pos (buffer-start-of-line buf pos)))
(define (buffer-apply-modeset! buf modeset)
(set-buffer-modeset! buf modeset))
@ -213,106 +217,101 @@
(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)
(buffer-lift rope-seek buf pos))
(buffer-lift rope-seek buf (clamp pos buf)))
(define (buffer-move-by! buf delta)
(buffer-move-to! buf (+ (buffer-pos buf) delta)))
(define (buffer-start-of-line buf pos-or-mtype)
(buffer-findf buf pos-or-mtype (lambda (ch) (equal? ch #\newline)) #:forward? #f))
(define (buffer-start-of-line buf)
(buffer-findf buf (lambda (ch) (equal? ch #\newline)) #:forward? #f))
(define (buffer-end-of-line buf pos-or-mtype)
(buffer-findf buf pos-or-mtype (lambda (ch) (equal? ch #\newline)) #:forward? #t))
(define (buffer-end-of-line buf)
(buffer-findf buf (lambda (ch) (equal? ch #\newline)) #:forward? #t))
(define (->pos buf pos-or-mtype what)
(clamp (if (number? pos-or-mtype)
pos-or-mtype
(buffer-mark-pos buf pos-or-mtype what))
buf))
(define (buffer-move-to-start-of-line! buf)
(buffer-move-to! buf (buffer-start-of-line buf)))
(define (buffer-mark-types buf)
(rope-marks (buffer-rope buf)))
(define (buffer-move-to-end-of-line! buf)
(buffer-move-to! buf (buffer-end-of-line buf)))
(define (buffer-mark* buf mtype)
(find-mark (buffer-rope buf) mtype))
(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-mark buf mtype [what 'buffer-mark])
(or (buffer-mark* buf mtype)
(error what "Mark type ~v not found; available mark types ~v" mtype (buffer-mark-types buf))))
(define (buffer-clear-mark! buf #:mark-type [mtype main-mark-type])
(define pos (find-mark-pos (buffer-rope buf) mtype))
(define (buffer-mark-pos* buf mtype)
(find-mark-pos (buffer-rope buf) mtype))
(define (buffer-mark-pos buf mtype [what 'buffer-mark-pos])
(or (buffer-mark-pos* buf mtype)
(error what "Mark type ~v not found; available mark types ~v" mtype (buffer-mark-types buf))))
(define (buffer-mark! buf mtype pos-or-mtype #:value [value #t])
(buffer-lift replace-mark buf mtype (->pos buf pos-or-mtype 'buffer-mark!) value))
(define (buffer-clear-mark! buf mtype)
(define pos (buffer-mark-pos* buf mtype))
(if pos
(buffer-lift clear-mark buf mtype pos)
buf))
(define (buffer-mark-pos buf [mtype main-mark-type])
(find-mark-pos (buffer-rope buf) mtype))
(define (buffer-move-mark! buf mtype delta)
(match-define (cons pos val) (buffer-mark buf mtype 'buffer-move-mark!))
(buffer-mark! buf mtype (+ pos delta) #:value val))
(define (buffer-region-split* buf pos mark)
(define lo (clamp (min pos mark) buf))
(define hi (clamp (max pos mark) buf))
(define (buffer-move-mark-to-start-of-line! buf mtype)
(define pos (buffer-mark-pos buf mtype 'buffer-move-mark-to-start-of-line!))
(buffer-mark! buf mtype (buffer-start-of-line buf pos)))
(define (buffer-move-mark-to-end-of-line! buf mtype)
(define pos (buffer-mark-pos buf mtype 'buffer-move-mark-to-end-of-line!))
(buffer-mark! buf mtype (buffer-end-of-line buf pos)))
(define (buffer-region-split buf pm1 pm2)
(define p1 (->pos buf pm1 'buffer-region-split))
(define p2 (->pos buf pm2 'buffer-region-split))
(define lo (min p1 p2))
(define hi (max p1 p2))
(define-values (l mr) (rope-split (buffer-rope buf) lo))
(define-values (m r) (rope-split mr (- hi lo)))
(values l lo m hi r))
(define (buffer-region-split buf
#:point [pos (buffer-pos buf)]
#:mark [mark (buffer-mark-pos buf)])
(buffer-region-split* buf pos mark))
(define (buffer-region buf
#:point [pos (buffer-pos buf)]
#:mark [mark (buffer-mark-pos buf)])
(define-values (_l _lo m _hi _r) (buffer-region-split* buf pos mark))
(define (buffer-region buf pm1 pm2)
(define-values (_l _lo m _hi _r) (buffer-region-split buf pm1 pm2))
m)
(define (buffer-region-update! buf updater
#:point [pos (buffer-pos buf)]
#:mark [mark (buffer-mark-pos buf)])
(define-values (l lo old-m hi r) (buffer-region-split* buf pos mark))
(define new-m (updater old-m))
(define (transfer-marks ro rn)
(define mtypes-to-transfer
(for/list ((mtype (rope-marks ro))
#:when (buffer-mark-type-preserve? (mark-type-info mtype)))
mtype))
(for/fold [(rn rn)] [(mtype mtypes-to-transfer)]
(define pos (case (mark-type-stickiness mtype)
[(left) 0]
[(right) (rope-size rn)]))
(set-mark rn mtype pos #t)))
(define (buffer-region-update! buf pm1 pm2 updater)
(define-values (l lo old-m hi r) (buffer-region-split buf pm1 pm2))
(define new-m (transfer-marks old-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]))
buf)
(define (buffer-insert! buf content-rope
#:point [pos0 (buffer-pos buf)]
#:move? [move? #t])
(define pos (clamp pos0 buf))
(define (buffer-insert! buf pos-or-mtype content-rope)
(define pos (->pos buf pos-or-mtype 'buffer-insert!))
(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 (buffer-replace-contents! buf content-rope)
(buffer-region-update! buf (lambda (_dontcare) content-rope) #:point 0 #:mark (buffer-size buf)))
(buffer-region-update! buf 0 (buffer-size buf) (lambda (_dontcare) content-rope)))
(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 (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 restore-mark-pos))
(when restore-point-pos (buffer-move-to! buf restore-point-pos))
(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)))]
(define result (f))
(restore!)
result))
(define (buffer-search* buf start-pos0 forward? move? find-delta)
(define start-pos (clamp start-pos0 buf))
(define (buffer-search* buf start-pos-or-mtype forward? find-delta)
(define start-pos (->pos buf start-pos-or-mtype 'buffer-search*))
(define-values (l r) (rope-split (buffer-rope buf) start-pos))
(define delta (find-delta (if forward? r l)))
(and delta
@ -320,23 +319,15 @@
[forward? delta]
[else (- delta (rope-size l))]))
buf)))
(if move?
(buffer-move-to! buf new-pos)
(buffer-seek! buf new-pos))
(buffer-seek! buf new-pos)
new-pos)))
(define (buffer-search buf needle
#:position [start-pos (buffer-pos buf)]
#:forward? [forward? #t]
#:move? [move? #f])
(buffer-search* buf start-pos forward? move?
(define (buffer-search buf start-pos-or-mtype needle #:forward? [forward? #t])
(buffer-search* buf start-pos-or-mtype forward?
(lambda (piece) (search-rope needle piece #:forward? forward?))))
(define (buffer-findf buf f
#:position [start-pos (buffer-pos buf)]
#:forward? [forward? #t]
#:move? [move? #f])
(buffer-search* buf start-pos forward? move?
(define (buffer-findf buf start-pos-or-mtype f #:forward? [forward? #t])
(buffer-search* buf start-pos-or-mtype forward?
(lambda (piece) (findf-in-rope f piece #:forward? forward?))))
(define (buffer-lift f buf . args)

37
rmacs/circular-list.rkt
View File

@ -15,9 +15,11 @@
circular-list-map
circular-list-filter
circular-list-remove
circular-list-memf)
circular-list-memf
circular-list-replacef)
(require racket/match)
(require (only-in racket/list splitf-at))
(struct circular-list ([front #:mutable]
[back #:mutable]
@ -130,6 +132,18 @@
(append seen (circular-list-back xs)))
(loop (cons a seen) (circular-cdr xs)))))))
(define (circular-list-replacef xs finder replacer)
(define (rejecter e) (not (finder e)))
(define-values (head tail) (splitf-at (circular-list-front xs) rejecter))
(if (null? tail)
(let-values (((head tail) (splitf-at (reverse (circular-list-back xs)) rejecter)))
(if (null? tail)
xs
(circular-list (circular-list-front xs)
(reverse (append head (replacer (car tail)) (cdr tail))))))
(circular-list (append head (replacer (car tail)) (cdr tail))
(circular-list-back xs))))
(module+ test
(require rackunit)
@ -149,6 +163,27 @@
(check-abcdef (circular-list '(a b c d e f) '()))
(check-abcdef (circular-list '() '(f e d c b a)))
(check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
(lambda (x) (eq? x 'e))
(lambda (x) (list 111))))
'(a b c d 111 f))
(check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
(lambda (x) (eq? x 'e))
(lambda (x) (list 111 222))))
'(a b c d 111 222 f))
(check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
(lambda (x) (eq? x 'b))
(lambda (x) (list 111))))
'(a 111 c d e f))
(check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
(lambda (x) (eq? x 'b))
(lambda (x) (list 111 222))))
'(a 111 222 c d e f))
(check-equal? (circular-list->list (circular-list-replacef (circular-list '(a b c) '(f e d))
(lambda (x) (eq? x 'x))
(lambda (x) (list 111 222))))
'(a b c d e f))
(check-equal? (match (circular-cons 1 circular-empty)
[(circular-cons a d) (cons a d)])
(cons 1 circular-empty))

93
rmacs/editor.rkt
View File

@ -2,8 +2,15 @@
(provide (except-out (struct-out editor) editor)
make-editor
open-window
close-other-windows
close-window
resize-window
select-window
visit-file!
render-editor!
editor-next-window
editor-prev-window
editor-command
editor-active-buffer
editor-active-modeset
@ -21,10 +28,11 @@
(require "mode.rkt")
(require "keys.rkt")
(require "rope.rkt")
(require "circular-list.rkt")
(struct editor (buffers ;; BufferGroup
[tty #:mutable] ;; Tty
[windows #:mutable] ;; (List (List Window SizeSpec)), abstract window layout
[windows #:mutable] ;; (CircularList (List Window SizeSpec)), abstract window layout
[active-window #:mutable] ;; (Option Window)
[running? #:mutable] ;; Boolean
[default-modeset #:mutable] ;; ModeSet
@ -37,7 +45,7 @@
(define w (make-window scratch))
(define e (editor g
tty
(list (list w (relative-size 1)))
(list->circular-list (list (list w (relative-size 1))))
w
#f
default-modeset))
@ -55,13 +63,68 @@
(or (lookup-buffer g title)
(configure-fresh-buffer! editor (make-buffer g title #:initial-contents initial-contents))))
(define (split-size s)
(match s
[(absolute-size _) s] ;; can't scale fixed-size windows
[(relative-size w) (relative-size (/ w 2))]))
(define (merge-sizes surviving disappearing)
(match* (surviving disappearing)
[((relative-size a) (relative-size b)) (relative-size (+ a b))]
[(_ _) surviving]))
(define (window-for-buffer editor buffer)
(cond [(circular-list-memf (lambda (e) (eq? (window-buffer (car e)) buffer))
(editor-windows editor)) => (compose car circular-car)]
[else #f]))
(define (entry-for? window) (lambda (e) (eq? (car e) window)))
(define (window->size-spec editor window)
(cond [(circular-list-memf (entry-for? window)
(editor-windows editor)) => (compose cadr circular-car)]
[else #f]))
(define (update-window-entry editor win updater)
(set-editor-windows! editor (circular-list-replacef (editor-windows editor)
(entry-for? win)
updater)))
(define (open-window editor buffer
#:size [size (relative-size 1)]
#:after-window [after-window (editor-active-window editor)]
#:proportional? [proportional? #f]
#: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 existing-w (window-for-buffer editor buffer))
(define existing-size (window->size-spec editor after-window))
(define new-size (if proportional? existing-size (split-size existing-size)))
(define new-point (or (and existing-w (buffer-mark-pos* buffer (window-point existing-w))) 0))
(define new-window (make-window buffer new-point))
(update-window-entry editor after-window
(lambda (e) (list (list after-window new-size)
(list new-window new-size))))
(when activate? (set-editor-active-window! editor new-window))
new-window)
(define (close-other-windows editor win)
(for ((entry (circular-list->list (editor-windows editor))) #:when (not (eq? (car entry) win)))
(set-window-buffer! (car entry) #f))
(set-editor-windows! editor (list->circular-list (list (list win (relative-size 1)))))
(set-editor-active-window! editor win))
(define (close-window editor win)
(define prev (editor-prev-window editor win))
(define prev-size (window->size-spec editor prev))
(define win-size (window->size-spec editor win))
(when (and prev (> (circular-length (editor-windows editor)) 1))
(when (eq? (editor-active-window editor) win) (set-editor-active-window! editor prev))
(update-window-entry editor win (lambda (e) '()))
(resize-window editor prev (merge-sizes prev-size win-size))))
(define (resize-window editor win size)
(update-window-entry editor win (lambda (e) (list (list win size)))))
(define (select-window editor win)
(set-editor-active-window! editor win))
(define (visit-file! editor filename)
(set-window-buffer! (editor-active-window editor)
@ -70,7 +133,7 @@
(define (render-editor! editor)
(render-windows! (editor-tty editor)
(editor-windows editor)
(circular-list->list (editor-windows editor))
(editor-active-window editor)))
(define (editor-active-buffer editor)
@ -81,6 +144,20 @@
(define b (editor-active-buffer editor))
(and b (buffer-modeset b)))
(define (editor-next-window editor win)
(cond [(circular-list-memf (entry-for? win)
(editor-windows editor)) => (compose car
circular-car
circular-list-rotate-forward)]
[else #f]))
(define (editor-prev-window editor win)
(cond [(circular-list-memf (entry-for? win)
(editor-windows editor)) => (compose car
circular-car
circular-list-rotate-backward)]
[else #f]))
(define (editor-command selector editor
#:keyseq [keyseq #f]
#:prefix-arg [prefix-arg '#:default])

128
rmacs/mode/fundamental.rkt
View File

@ -8,10 +8,10 @@
(define fundamental-mode (make-mode "fundamental"))
(define-command fundamental-mode (self-insert-command buf #:keyseq keyseq)
(define-command fundamental-mode (self-insert-command buf #:window win #:keyseq keyseq)
(match keyseq
[(list (key (? char? ch) modifiers)) #:when (set-empty? (set-remove modifiers 'shift))
(buffer-insert! buf (string->rope (string ch)))]
(buffer-insert! buf (window-point win) (string->rope (string ch)))]
[_ #f]))
(define-command fundamental-mode (unbound-key-sequence buf #:keyseq keyseq)
@ -19,101 +19,119 @@
(define-key fundamental-mode (list "C-q" '#:default) self-insert-command)
(define-command fundamental-mode (newline buf)
(define-command fundamental-mode (newline buf #:window win)
#:bind-key "C-m"
#:bind-key "C-j"
(buffer-insert! buf (string->rope "\n")))
(buffer-insert! buf (window-point win) (string->rope "\n")))
(define (move-forward-n-lines buf count)
(define (move-forward-n-lines win count)
(define buf (window-buffer win))
(for ((i count))
(buffer-move-to-end-of-line! buf)
(buffer-move-by! buf 1)))
(buffer-move-mark-to-end-of-line! buf (window-point win))
(buffer-move-mark! buf (window-point win) 1)))
(define (move-backward-n-lines buf count)
(define (move-backward-n-lines win count)
(define buf (window-buffer win))
(for ((i count))
(buffer-move-to-start-of-line! buf)
(buffer-move-by! buf -1)))
(buffer-move-mark-to-start-of-line! buf (window-point win))
(buffer-move-mark! buf (window-point win) -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 (move-to-column win col)
(define buf (window-buffer win))
(define eol-pos (buffer-end-of-line buf (window-point win)))
(define sol-pos (buffer-start-of-line buf (window-point win)))
(buffer-mark! buf (window-point win) (+ sol-pos (min col (- eol-pos sol-pos)))))
(define-command fundamental-mode (forward-char buf #:prefix-arg [count 1])
(define-command fundamental-mode (forward-char buf #:window win #:prefix-arg [count 1])
#:bind-key "C-f"
#:bind-key "<right>"
(buffer-move-by! buf count))
(buffer-move-mark! buf (window-point win) count))
(define-command fundamental-mode (backward-char buf #:prefix-arg [count 1])
(define-command fundamental-mode (backward-char buf #:window win #:prefix-arg [count 1])
#:bind-key "C-b"
#:bind-key "<left>"
(buffer-move-by! buf (- count)))
(buffer-move-mark! buf (window-point win) (- count)))
(define-command fundamental-mode (next-line buf #:prefix-arg [count 1])
(define-command fundamental-mode (next-line buf #:window win #:prefix-arg [count 1])
#:bind-key "C-n"
#:bind-key "<down>"
(define col (buffer-column buf))
(move-forward-n-lines buf count)
(move-to-column buf col))
(define col (buffer-column buf (window-point win)))
(move-forward-n-lines win count)
(move-to-column win col))
(define-command fundamental-mode (prev-line buf #:prefix-arg [count 1])
(define-command fundamental-mode (prev-line buf #:window win #:prefix-arg [count 1])
#:bind-key "C-p"
#:bind-key "<up>"
(define col (buffer-column buf))
(move-backward-n-lines buf count)
(move-to-column buf col))
(define col (buffer-column buf (window-point win)))
(move-backward-n-lines win count)
(move-to-column win col))
(define-command fundamental-mode (move-end-of-line buf #:prefix-arg [count 1])
(define-command fundamental-mode (move-end-of-line buf #:window win #:prefix-arg [count 1])
#:bind-key "C-e"
#:bind-key "<end>"
(when (positive? count) (move-forward-n-lines buf (- count 1)))
(buffer-move-to-end-of-line! buf))
(when (positive? count) (move-forward-n-lines win (- count 1)))
(buffer-move-mark-to-end-of-line! buf (window-point win)))
(define-command fundamental-mode (move-beginning-of-line buf #:prefix-arg [count 1])
(define-command fundamental-mode (move-beginning-of-line buf #:window win #:prefix-arg [count 1])
#:bind-key "C-a"
#:bind-key "<home>"
(when (positive? count) (move-forward-n-lines buf (- count 1)))
(buffer-move-to-start-of-line! buf))
(when (positive? count) (move-forward-n-lines win (- count 1)))
(buffer-move-mark-to-start-of-line! buf (window-point win)))
(define-command fundamental-mode (delete-backward-char buf #:prefix-arg [count 1])
(define-command fundamental-mode (delete-backward-char buf #:window win #:prefix-arg [count 1])
#:bind-key "<backspace>"
#:bind-key "C-h" ;; differs from GNU emacs
(buffer-region-update! buf
(lambda (_deleted) (empty-rope))
#:mark (- (buffer-pos buf) count)))
(define pos (buffer-mark-pos buf (window-point win)))
(buffer-region-update! buf (- pos 1) pos (lambda (_deleted) (empty-rope))))
(define-command fundamental-mode (delete-forward-char buf #:prefix-arg [count 1])
(define-command fundamental-mode (delete-forward-char buf #:window win #:prefix-arg [count 1])
#:bind-key "<delete>"
#:bind-key "C-d"
(buffer-region-update! buf
(lambda (_deleted) (empty-rope))
#:mark (+ (buffer-pos buf) count)))
(define pos (buffer-mark-pos buf (window-point win)))
(buffer-region-update! buf pos (+ pos 1) (lambda (_deleted) (empty-rope))))
(define-command fundamental-mode (beginning-of-buffer buf #:prefix-arg [tenths 0])
(define-command fundamental-mode (beginning-of-buffer buf #:window win #:prefix-arg [tenths 0])
#:bind-key "M-<"
#:bind-key "C-<home>"
#:bind-key "<begin>"
(if (eq? tenths '#:prefix) (set! tenths 0) (buffer-mark! buf))
(buffer-move-to! buf (* (buffer-size buf) (max 0 (min 10 tenths)) 1/10)))
(if (eq? tenths '#:prefix) (set! tenths 0) (window-mark! win))
(window-move-to! win (* (buffer-size buf) (max 0 (min 10 tenths)) 1/10)))
(define-command fundamental-mode (end-of-buffer buf #:prefix-arg [tenths 0])
(define-command fundamental-mode (end-of-buffer buf #:window win #:prefix-arg [tenths 0])
#:bind-key "M->"
#:bind-key "C-<end>"
(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)))
(if (eq? tenths '#:prefix) (set! tenths 0) (window-mark! win))
(window-move-to! win (* (buffer-size buf) (- 10 (max 0 (min 10 tenths))) 1/10)))
(define-command fundamental-mode (exchange-point-and-mark buf)
(define-command fundamental-mode (exchange-point-and-mark buf #:window win)
#:bind-key "C-x C-x"
(define m (buffer-mark-pos buf))
(define m (buffer-mark-pos* buf (window-mark win)))
(when m
(define p (buffer-pos buf))
(buffer-mark! buf p)
(buffer-move-to! buf m)))
(define p (buffer-mark-pos buf (window-point win)))
(window-mark! win p)
(window-move-to! win m)))
(define-command fundamental-mode (set-mark-command buf #:prefix-arg arg)
(define-command fundamental-mode (set-mark-command buf #:window win #:prefix-arg arg)
#:bind-key "C-@"
#:bind-key "C-space"
(if (eq? arg '#:prefix)
(let ((m (buffer-mark-pos buf)))
(and m (buffer-move-to! buf m)))
(buffer-mark! buf)))
(let ((m (buffer-mark-pos* buf (window-mark win))))
(and m (window-move-to! win m)))
(window-mark! win (window-point win))))
(define-command fundamental-mode (split-window-below buf #:window win #:editor ed)
#:bind-key "C-x 2"
(open-window ed buf #:after-window win))
(define-command fundamental-mode (delete-other-windows buf #:window win #:editor ed)
#:bind-key "C-x 1"
(close-other-windows ed win))
(define-command fundamental-mode (delete-window buf #:window win #:editor ed)
#:bind-key "C-x 0"
(close-window ed win))
(define-command fundamental-mode (other-window buf #:window win #:editor ed)
#:bind-key "C-tab"
#:bind-key "C-x o"
(select-window ed (editor-next-window ed win)))

48
rmacs/render.rkt
View File

@ -1,6 +1,8 @@
#lang racket/base
(provide render-windows!)
(provide (struct-out absolute-size)
(struct-out relative-size)
render-windows!)
(require racket/match)
@ -9,7 +11,11 @@
(require "display.rkt")
(require "rope.rkt")
(define top-of-window-mtype (mark-type "top-of-window" 'left))
;; A SizeSpec is either
;; -- (absolute-size PositiveInteger), a specific size in screen rows
;; -- (relative-size PositiveReal), a weighted window size
(struct absolute-size (lines) #:prefab)
(struct relative-size (weight) #:prefab)
(define (newline? c) (equal? c #\newline))
(define (not-newline? c) (not (newline? c)))
@ -23,16 +29,16 @@
;; will end up at a configurable percentage of the way down the
;; window.
;;
;; Buffer Nat -> Nat
;; 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 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))
;; Window Nat -> Nat
;; Ensures that window-top is sanely positioned with respect to
;; window-point. Returns the new position of window-top.
(define (frame! win available-line-count
#:preferred-position-fraction [preferred-position-fraction 1/2])
(define buf (window-buffer win))
(define old-top-of-window-pos (or (buffer-mark-pos* buf (window-top win)) 0))
(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 (window-point win) newline? #:forward? #f))
(line-count 0)
(top-of-window-pos old-top-of-window-pos))
(define new-top-of-window-pos
@ -41,10 +47,10 @@
[(= pos old-top-of-window-pos)
old-top-of-window-pos]
[(>= line-count (- available-line-count 1))
(buffer-mark! buf new-top-of-window-pos #:mark-type top-of-window-mtype)
(buffer-mark! buf (window-top win) new-top-of-window-pos)
new-top-of-window-pos]
[else
(loop (buffer-findf buf newline? #:forward? #f #:position (- pos 1))
(loop (buffer-findf buf (- pos 1) newline? #:forward? #f)
(+ line-count 1)
new-top-of-window-pos)])))
@ -84,10 +90,11 @@
[_
(emit (string c))])])))
(define (render-buffer! t b window-top window-height is-active?)
(define (render-window! t win window-top window-height is-active?)
(define buf (window-buffer win))
(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 top-of-window-pos (frame! win available-line-count))
(define cursor-pos (buffer-mark-pos buf (window-point win)))
(tty-goto t window-top 0)
(tty-body-style t is-active?)
(define cursor-coordinates
@ -98,8 +105,8 @@
[(>= line-count available-line-count)
cursor-coordinates]
[else
(define eol-pos (buffer-findf b newline? #:position sol-pos))
(define line (rope->string (buffer-region b #:point eol-pos #:mark sol-pos)))
(define eol-pos (buffer-findf buf sol-pos newline?))
(define line (rope->string (buffer-region buf sol-pos eol-pos)))
(define-values (formatted-line cursor-offset)
(format-line line (tty-columns t) (- cursor-pos sol-pos)))
(tty-display t formatted-line)
@ -111,8 +118,8 @@
(list (+ line-count window-top) cursor-offset)
cursor-coordinates))])))
(tty-statusline-style t is-active?)
(tty-display t (if is-active? "== " "-- ") (buffer-title b) " ")
(let ((remaining-length (- (tty-columns t) 4 (string-length (buffer-title b)))))
(tty-display t (if is-active? "== " "-- ") (buffer-title buf) " ")
(let ((remaining-length (- (tty-columns t) 4 (string-length (buffer-title buf)))))
(when (positive? remaining-length)
(tty-display t (make-string remaining-length (if is-active? #\= #\-)))))
cursor-coordinates)
@ -152,8 +159,7 @@
(for/fold [(cursor-position #f)] [(e layout)]
(match-define (list w window-top window-height) e)
(define is-active? (eq? w active-window))
(define b (window-buffer w))
(define window-cursor-position (render-buffer! t b window-top window-height is-active?))
(define window-cursor-position (render-window! t w window-top window-height is-active?))
(if is-active? window-cursor-position cursor-position)))
(when active-cursor-position
(tty-goto t (car active-cursor-position) (cadr active-cursor-position)))

4
rmacs/rope.rkt
View File

@ -48,9 +48,9 @@
;; Stickiness adheres. What Finseth calls a "normal mark" has 'right
;; stickiness, and what he calls a "fixed mark" has 'left stickiness.
;; A MarkType is a (mark-type String Stickiness). MarkTypes can be
;; A MarkType is a (mark-type Any Stickiness). MarkTypes can be
;; associated with a set of Any values at each position in the rope.
(struct mark-type (name stickiness) #:prefab)
(struct mark-type (info stickiness) #:prefab)
;; A Strand is a (strand String Number Number), representing a
;; substring of a string.

63
rmacs/window.rkt
View File

@ -1,46 +1,55 @@
#lang racket/base
(provide (except-out (struct-out window) window)
(struct-out absolute-size)
(struct-out relative-size)
(provide (except-out (struct-out window) window set-window-buffer!)
(rename-out [set-window-buffer!* set-window-buffer!])
make-window
window-split
window-command
window-mark!
window-move-to!
)
(require racket/match)
(require "buffer.rkt")
(require "lists.rkt")
;; A SizeSpec is either
;; -- (absolute-size PositiveInteger), a specific size in screen rows
;; -- (relative-size PositiveReal), a weighted window size
(struct absolute-size (lines) #:prefab)
(struct relative-size (weight) #:prefab)
(require "rope.rkt")
(struct window (id ;; Symbol
[buffer #:mutable] ;; Buffer
top ;; MarkType
point ;; MarkType
mark ;; MarkType
[buffer #:mutable] ;; (Option Buffer)
) #:prefab)
(define (make-window initial-buffer)
(window (gensym 'window)
initial-buffer))
(define (make-window initial-buffer [initial-point-or-mark 0])
(define id (gensym 'window))
(define w (window id
(mark-type (buffer-mark-type 'top id #f) 'left)
(mark-type (buffer-mark-type 'point id #t) 'right)
(mark-type (buffer-mark-type 'mark id #f) 'left)
#f))
(set-window-buffer!* w initial-buffer initial-point-or-mark) ;; sets initial marks
w)
(define (scale-size s)
(match s
[(absolute-size _) s] ;; can't scale fixed-size windows
[(relative-size w) (relative-size (/ w 2))]))
(define (window-split w ws #:proportional? [proportional? #f])
(replacef ws
(lambda (e) (eq? (car e) w))
(lambda (e)
(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 (set-window-buffer!* win new [point-or-mark 0])
(define old (window-buffer win))
(when old
(buffer-clear-mark! old (window-top win))
(buffer-clear-mark! old (window-point win))
(buffer-clear-mark! old (window-mark win)))
(set-window-buffer! win new)
(when new
(buffer-mark! new (window-point win) point-or-mark))
(void))
(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))
(define (window-mark! win [pos (window-point win)])
(buffer-mark! (window-buffer win) (window-mark win) pos)
win)
(define (window-move-to! win pos)
(buffer-mark! (window-buffer win) (window-point win) pos)
win)