Echo area

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))
+  (define ws (windows-for-buffer editor buffer))
-                             (editor-windows editor)) => (compose car circular-car)]
+  (and (pair? ws) (car ws)))
-        [else #f]))
 
 (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)

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-<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)
-    (window-mark! win p)
     (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"

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?)
+  (when (window-status-line? win)
-  (let* ((prefix (format "-:~a- ~a " (if (buffer-dirty? buf) "**" "--") (buffer-title buf)))
+    (tty-statusline-style t is-active?)
-         (remaining-length (- (tty-columns t) (string-length prefix))))
+    (let* ((prefix (format "-:~a- ~a " (if (buffer-dirty? buf) "**" "--") (buffer-title buf)))
-    (tty-display t prefix)
+           (remaining-length (- (tty-columns t) (string-length prefix))))
-    (when (positive? remaining-length) (tty-display t (make-string remaining-length #\-))))
+      (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)
+  (define reserved-lines (foldl + miniwin-height (map (lambda (e)
-                                           (match (cadr e)
+                                                        (match (cadr e)
-                                             [(absolute-size lines) lines]
+                                                          [(absolute-size lines) lines]
-                                             [(relative-size _) 0])) ws)))
+                                                          [(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
+            (match ws
-      ['() '()]
+              ['() '()]
-      [(cons (list w (and spec (absolute-size lines))) rest)
+              [(cons (list w (and spec (absolute-size lines))) rest)
-       (cons (layout w spec offset 0 total-width lines)
+               (cons (layout w spec offset 0 total-width lines)
-             (loop rest (+ offset lines) remaining))]
+                     (loop rest (+ offset lines) remaining))]
-      [(cons (list w (and spec (relative-size weight))) rest)
+              [(cons (list w (and spec (relative-size weight))) rest)
-       (define height (max minimum-height
+               (define height (max minimum-height
-                           (inexact->exact
+                                   (inexact->exact
-                            (round (* proportional-lines (/ weight total-weight))))))
+                                    (round (* proportional-lines (/ weight total-weight))))))
-       (if (>= remaining height)
+               (if (>= remaining height)
-           (if (null? rest)
+                   (if (null? rest)
-               (list (layout w spec offset 0 total-width remaining))
+                       (list (layout w spec offset 0 total-width remaining))
-               (cons (layout w spec offset 0 total-width height)
+                       (cons (layout w spec offset 0 total-width height)
-                     (loop rest (+ offset height) (- remaining height))))
+                             (loop rest (+ offset height) (- remaining height))))
-           (if (>= remaining minimum-height)
+                   (if (>= remaining minimum-height)
-               (list (layout w spec offset 0 total-width remaining))
+                       (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)

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