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

Echo area

This commit is contained in:
Tony Garnock-Jones 2014-12-28 15:33:00 -05:00
parent 635c0d6359
commit 1ca7fbc23e
4 changed files with 93 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

43
rmacs/editor.rkt
View File

@ -10,6 +10,8 @@
close-window
resize-window
select-window
windows-for-buffer
window-for-buffer
visit-file!
render-editor!
editor-next-window
@ -21,7 +23,9 @@
editor-active-modeset
editor-mainloop
editor-request-shutdown!
editor-force-redisplay!)
editor-force-redisplay!
clear-message
message)
(require racket/match)
@ -43,6 +47,8 @@
[default-modeset #:mutable] ;; ModeSet
[layout #:mutable] ;; (Option (List Layout))
[last-command #:mutable] ;; (Option Command)
echo-area ;; Buffer
mini-window ;; Window
) #:prefab)
(define (make-editor #:tty [tty (stdin-tty)]
@ -50,12 +56,15 @@
(define g (make-buffergroup))
(define scratch (make-buffer g "*scratch*"
#:initial-contents ";; This is the scratch buffer.\n\n"))
(define echo-area (make-buffer #f "*echo-area*"))
(define w (make-window scratch))
(define ws (list->circular-list (list (list w (relative-size 1)))))
(define e (editor g tty ws w #f default-modeset #f #f))
(define miniwin (make-window echo-area))
(define e (editor g tty ws w #f default-modeset #f #f echo-area miniwin))
(initialize-buffergroup! g e)
(configure-fresh-buffer! e scratch)
(window-move-to! w (buffer-size scratch))
(set-window-status-line?! miniwin #f)
e)
(define (configure-fresh-buffer! editor buffer)
@ -78,10 +87,13 @@
[((relative-size a) (relative-size b)) (relative-size (+ a b))]
[(_ _) surviving]))
(define (windows-for-buffer editor buffer)
(map car (filter (lambda (e) (eq? (window-buffer (car e)) buffer))
(circular-list->list (editor-windows editor)))))
(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 ws (windows-for-buffer editor buffer))
(and (pair? ws) (car ws)))
(define (entry-for? window) (lambda (e) (eq? (car e) window)))
@ -91,6 +103,7 @@
(define (layout! editor)
(when (not (editor-layout editor))
(set-editor-layout! editor (layout-windows (circular-list->list (editor-windows editor))
(editor-mini-window editor)
(tty-columns (editor-tty editor))
(tty-rows (editor-tty editor)))))
(editor-layout editor))
@ -189,8 +202,10 @@
(window-command selector (editor-active-window editor) #:keyseq keyseq #:prefix-arg prefix-arg))
(define (invoke/history cmd)
(define editor (command-editor cmd))
(clear-message editor)
(define result (invoke cmd))
(set-editor-last-command! (command-editor cmd) cmd)
(set-editor-last-command! editor cmd)
result)
(define (editor-last-command? editor . possible-selectors)
@ -272,6 +287,22 @@
(tty-reset (editor-tty editor))
(invalidate-layout! editor))
(define (clear-message editor)
(buffer-replace-contents! (editor-echo-area editor) (empty-rope))
(invalidate-layout! editor))
(define (message editor fmt . args)
(define msg (string->rope (apply format fmt args)))
(let* ((msgbuf (find-buffer editor "*Messages*"))
(msgwins (filter (lambda (w) (equal? (buffer-mark-pos msgbuf (window-point w))
(buffer-size msgbuf)))
(windows-for-buffer editor msgbuf))))
(buffer-insert! msgbuf (buffer-size msgbuf) (rope-append msg (string->rope "\n")))
(for ((w msgwins)) (buffer-mark! msgbuf (window-point w) (buffer-size msgbuf))))
(buffer-replace-contents! (editor-echo-area editor) msg)
(invalidate-layout! editor)
(render-editor! editor))
;;---------------------------------------------------------------------------
(define-command kernel-mode (save-buffers-kill-terminal buf #:editor ed)

14
rmacs/mode/fundamental.rkt
View File

@ -101,25 +101,29 @@
(define pos (buffer-mark-pos buf (window-point win)))
(buffer-region-update! buf pos (+ pos 1) (lambda (_deleted) (empty-rope))))
(define (set-window-mark! win [pos (window-point win)])
(window-mark! win pos)
(message (window-editor win) "Mark set")
pos)
(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) (window-mark! win))
(if (eq? tenths '#:prefix) (set! tenths 0) (set-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 #:window win #:prefix-arg [tenths 0])
#:bind-key "M->"
#:bind-key "C-<end>"
(if (eq? tenths '#:prefix) (set! tenths 0) (window-mark! win))
(if (eq? tenths '#:prefix) (set! tenths 0) (set-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 #:window win)
#:bind-key "C-x C-x"
(define m (buffer-mark-pos* buf (window-mark win)))
(when m
(define p (buffer-mark-pos buf (window-point win)))
(window-mark! win p)
(window-mark! win)
(window-move-to! win m)))
(define-command fundamental-mode (set-mark-command buf #:window win #:prefix-arg arg)
@ -128,7 +132,7 @@
(if (eq? arg '#:prefix)
(let ((m (buffer-mark-pos* buf (window-mark win))))
(and m (window-move-to! win m)))
(window-mark! win (window-point win))))
(set-window-mark! win)))
(define-command fundamental-mode (split-window-below buf #:window win #:editor ed)
#:bind-key "C-x 2"

22
rmacs/render.rkt
View File

@ -79,7 +79,7 @@
(define (render-window! t win window-top window-width window-height is-active?)
(define buf (window-buffer win))
(define available-line-count (- window-height 1))
(define available-line-count (if (window-status-line? win) (- window-height 1) window-height))
(define spans (frame! win available-line-count window-width))
(define cursor-pos (buffer-mark-pos buf (window-point win)))
(tty-goto t window-top 0)
@ -120,25 +120,29 @@
(define cursor-coordinates (render-top-spans spans 0 #f))
(when (window-status-line? win)
(tty-statusline-style t is-active?)
(let* ((prefix (format "-:~a- ~a " (if (buffer-dirty? buf) "**" "--") (buffer-title buf)))
(remaining-length (- (tty-columns t) (string-length prefix))))
(tty-display t prefix)
(when (positive? remaining-length) (tty-display t (make-string remaining-length #\-))))
(when (positive? remaining-length) (tty-display t (make-string remaining-length #\-)))))
cursor-coordinates)
(define (layout-windows ws total-width total-height [minimum-height 4])
(define (layout-windows ws miniwin total-width total-height [minimum-height 4])
(define miniwin-spans
(frame! miniwin (min 4 total-height) total-width #:preferred-position-fraction 1))
(define miniwin-height (length miniwin-spans))
(define total-weight (foldl + 0 (map (lambda (e)
(match (cadr e)
[(absolute-size _) 0]
[(relative-size w) w])) ws)))
(define reserved-lines (foldl + 0 (map (lambda (e)
(define reserved-lines (foldl + miniwin-height (map (lambda (e)
(match (cadr e)
[(absolute-size lines) lines]
[(relative-size _) 0])) ws)))
(define proportional-lines (- total-height reserved-lines))
(let loop ((ws ws) (offset 0) (remaining proportional-lines))
(append (let loop ((ws ws) (offset 0) (remaining proportional-lines))
(match ws
['() '()]
[(cons (list w (and spec (absolute-size lines))) rest)
@ -155,7 +159,13 @@
(loop rest (+ offset height) (- remaining height))))
(if (>= remaining minimum-height)
(list (layout w spec offset 0 total-width remaining))
'()))])))
'()))]))
(list (layout miniwin
(absolute-size miniwin-height)
(- total-height miniwin-height)
0
total-width
miniwin-height))))
(define (render-windows! t layouts active-window)
(tty-body-style t #f)

9
rmacs/window.rkt
View File

@ -3,6 +3,7 @@
(provide (except-out (struct-out window) window set-window-buffer!)
(rename-out [set-window-buffer!* set-window-buffer!])
make-window
window-editor
window-command
window-mark!
window-move-to!
@ -18,6 +19,7 @@
point ;; MarkType
mark ;; MarkType
[buffer #:mutable] ;; (Option Buffer)
[status-line? #:mutable] ;; Boolean
) #:prefab)
(define (make-window initial-buffer #:point [initial-point-or-mark 0])
@ -26,10 +28,15 @@
(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))
#f
#t))
(set-window-buffer!* w initial-buffer initial-point-or-mark) ;; sets initial marks
w)
(define (window-editor w)
(and (window-buffer w)
(buffer-editor (window-buffer w))))
(define (set-window-buffer!* win new [point-or-mark 0])
(define old (window-buffer win))
(when old