From 1ca7fbc23e79daae1a3a7762cbd77ce77672c88e Mon Sep 17 00:00:00 2001 From: Tony Garnock-Jones Date: Sun, 28 Dec 2014 15:33:00 -0500 Subject: [PATCH] Echo area --- rmacs/editor.rkt | 43 ++++++++++++++++++++---- rmacs/mode/fundamental.rkt | 14 +++++--- rmacs/render.rkt | 68 ++++++++++++++++++++++---------------- rmacs/window.rkt | 9 ++++- 4 files changed, 93 insertions(+), 41 deletions(-) diff --git a/rmacs/editor.rkt b/rmacs/editor.rkt index 6e3bfe6..f34d269 100644 --- a/rmacs/editor.rkt +++ b/rmacs/editor.rkt @@ -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) diff --git a/rmacs/mode/fundamental.rkt b/rmacs/mode/fundamental.rkt index 92a14a8..0c9346c 100644 --- a/rmacs/mode/fundamental.rkt +++ b/rmacs/mode/fundamental.rkt @@ -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-" #:bind-key "" - (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-" - (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" diff --git a/rmacs/render.rkt b/rmacs/render.rkt index 2b24066..e302caf 100644 --- a/rmacs/render.rkt +++ b/rmacs/render.rkt @@ -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,42 +120,52 @@ (define cursor-coordinates (render-top-spans spans 0 #f)) - (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 (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 #\-))))) 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) - (match (cadr e) - [(absolute-size lines) lines] - [(relative-size _) 0])) ws))) + (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)) - (match ws - ['() '()] - [(cons (list w (and spec (absolute-size lines))) rest) - (cons (layout w spec offset 0 total-width lines) - (loop rest (+ offset lines) remaining))] - [(cons (list w (and spec (relative-size weight))) rest) - (define height (max minimum-height - (inexact->exact - (round (* proportional-lines (/ weight total-weight)))))) - (if (>= remaining height) - (if (null? rest) - (list (layout w spec offset 0 total-width remaining)) - (cons (layout w spec offset 0 total-width height) - (loop rest (+ offset height) (- remaining height)))) - (if (>= remaining minimum-height) - (list (layout w spec offset 0 total-width remaining)) - '()))]))) + (append (let loop ((ws ws) (offset 0) (remaining proportional-lines)) + (match ws + ['() '()] + [(cons (list w (and spec (absolute-size lines))) rest) + (cons (layout w spec offset 0 total-width lines) + (loop rest (+ offset lines) remaining))] + [(cons (list w (and spec (relative-size weight))) rest) + (define height (max minimum-height + (inexact->exact + (round (* proportional-lines (/ weight total-weight)))))) + (if (>= remaining height) + (if (null? rest) + (list (layout w spec offset 0 total-width remaining)) + (cons (layout w spec offset 0 total-width height) + (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) diff --git a/rmacs/window.rkt b/rmacs/window.rkt index 2132301..c9a20da 100644 --- a/rmacs/window.rkt +++ b/rmacs/window.rkt @@ -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