recursive editing and M-x

rmacs/api.rkt

@@ -7,10 +7,12 @@
 (require "keys.rkt")
 (require "rope.rkt")
 (require "window.rkt")
+(require "minibuf.rkt")
 
 (provide (all-from-out "mode.rkt"
                        "editor.rkt"
                        "buffer.rkt"
                        "keys.rkt"
                        "rope.rkt"
-                       "window.rkt"))
+                       "window.rkt"
+                       "minibuf.rkt"))

rmacs/buffer.rkt

@@ -56,6 +56,8 @@
          define-buffer-local
 
          (except-out (struct-out command) command)
+         (struct-out exn:abort)
+         abort
          copy-command
          (rename-out [make-command command])
          invoke
@@ -95,6 +97,8 @@
                 [locals #:mutable] ;; (HashEqTable Symbol Any)
                 ) #:prefab)
 
+(struct exn:abort exn (detail duration) #:transparent)
+
 (struct command (selector ;; Symbol
                  buffer ;; Buffer
                  window ;; (Option Window)
@@ -328,7 +332,8 @@
 (define (transfer-marks ro rn)
   (define mtypes-to-transfer
     (for/list ((mtype (rope-marks ro))
-               #:when (buffer-mark-type-preserve? (mark-type-info mtype)))
+               #:when (and (buffer-mark-type? (mark-type-info mtype))
+                           (buffer-mark-type-preserve? (mark-type-info mtype))))
       mtype))
   (for/fold [(rn rn)] [(mtype mtypes-to-transfer)]
     (define pos (case (mark-type-stickiness mtype)
@@ -341,14 +346,14 @@
   (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))
-  (set-buffer-dirty?! buf #t)
+  (when (buffer-source buf) (set-buffer-dirty?! buf #t))
   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))
-  (set-buffer-dirty?! buf #t)
+  (when (buffer-source buf) (set-buffer-dirty?! buf #t))
   buf)
 
 (define (buffer-replace-contents! buf content-rope)
@@ -377,7 +382,7 @@
 (define (buffer-local name [default #f])
   (case-lambda
     [(buf)
-     (hash-ref (buffer-locals buf) name default)]
+     (hash-ref (buffer-locals buf) name (lambda () default))]
     [(buf val)
      (set-buffer-locals! buf (if (equal? val default)
                                  (hash-remove (buffer-locals buf) name)
@@ -396,6 +401,14 @@
 
 ;;---------------------------------------------------------------------------
 
+(define (abort #:detail [detail #f]
+               #:duration [duration #f]
+               fmt . args)
+  (raise (exn:abort (apply format fmt args)
+                    (current-continuation-marks)
+                    detail
+                    duration)))
+
 (define (make-command selector buffer-or-command
                       #:window [window #f]
                       #:editor [editor #f]
@@ -425,7 +438,7 @@
   (match-define (command selector buf _ _ keyseq _) cmd)
   (define handler (modeset-lookup-command (buffer-modeset buf) selector))
   (when (not handler)
-    (error 'invoke "Unhandled command ~a (key sequence: ~a)"
+    (abort "Unhandled command ~a (key sequence: ~a)"
            selector
            (if keyseq (keyseq->keyspec keyseq) "N/A")))
   (handler cmd))

rmacs/editor.rkt

@@ -2,6 +2,7 @@
 
 (provide (except-out (struct-out editor) editor)
          make-editor
+         configure-fresh-buffer!
          window-layout
          window-width
          window-height
@@ -26,8 +27,8 @@
          editor-force-redisplay!
          clear-message
          message
-         (struct-out exn:abort)
+         start-recursive-edit
-         abort)
+         abandon-recursive-edit)
 
 (require racket/match)
 
@@ -41,8 +42,6 @@
 (require "circular-list.rkt")
 (require "file.rkt")
 
-(struct exn:abort exn (detail) #:transparent)
-
 (struct editor (buffers ;; BufferGroup
                 [tty #:mutable] ;; Tty
                 [windows #:mutable] ;; (CircularList (List Window SizeSpec)), abstract window layout
@@ -53,6 +52,8 @@
                 [last-command #:mutable] ;; (Option Command)
                 echo-area ;; Buffer
                 mini-window ;; Window
+                [message-expiry-time #:mutable] ;; (Option Number)
+                [recursive-edit #:mutable] ;; (Option Buffer)
                 ) #:prefab)
 
 (define (make-editor #:tty [tty (stdin-tty)]
@@ -64,7 +65,7 @@
   (define w (make-window scratch))
   (define ws (list->circular-list (list (list w (relative-size 1)))))
   (define miniwin (make-window echo-area))
-  (define e (editor g tty ws w #f default-modeset #f #f echo-area miniwin))
+  (define e (editor g tty ws w #f default-modeset #f #f echo-area miniwin #f #f))
   (initialize-buffergroup! g e)
   (configure-fresh-buffer! e scratch)
   (window-move-to! w (buffer-size scratch))
@@ -83,7 +84,7 @@
 
 (define (split-size s)
   (match s
-    [(absolute-size _) s] ;; can't scale fixed-size windows
+    [(absolute-size _) (relative-size 1)] ;; can't scale fixed-size windows
     [(relative-size w) (relative-size (/ w 2))]))
 
 (define (merge-sizes surviving disappearing)
@@ -165,7 +166,8 @@
   (update-window-entry editor win (lambda (e) (list (list win size)))))
 
 (define (select-window editor win)
-  (set-editor-active-window! editor win))
+  (when (window-layout editor win)
+    (set-editor-active-window! editor win)))
 
 (define (visit-file! editor filename)
   (set-window-buffer! (editor-active-window editor)
@@ -203,13 +205,17 @@
 (define (editor-command selector editor
                         #:keyseq [keyseq #f]
                         #:prefix-arg [prefix-arg '#:default])
-  (window-command selector (editor-active-window editor) #:keyseq keyseq #:prefix-arg prefix-arg))
+  (window-command selector (editor-active-window editor)
+                  #:editor editor
+                  #:keyseq keyseq
+                  #:prefix-arg prefix-arg))
 
 (define (invoke/history cmd)
   (define editor (command-editor cmd))
   (clear-message editor)
   (with-handlers* ([exn:abort? (lambda (e)
-                                 (message editor "~a" (exn-message e))
+                                 (message editor "~a" (exn-message e)
+                                          #:duration (exn:abort-duration e))
                                  (void))])
     (define result (invoke cmd))
     (set-editor-last-command! editor cmd)
@@ -253,6 +259,13 @@
                                 (lambda (_)
                                   (loop total-keyseq '() next-handler next-repaint-deadline)))
                     never-evt)
+                (let ((expiry-time (editor-message-expiry-time editor)))
+                  (if expiry-time
+                      (handle-evt (alarm-evt expiry-time)
+                                  (lambda (_)
+                                    (clear-message editor)
+                                    (loop total-keyseq '() next-handler 0)))
+                      never-evt))
                 (handle-evt (tty-next-key-evt (editor-tty editor))
                             (lambda (new-key)
                               (define new-input (list new-key))
@@ -269,12 +282,12 @@
        [else
         (match (handler editor input)
           [(unbound-key-sequence)
-           (if (invoke/history (editor-command 'unbound-key-sequence editor
+           (when (not (invoke/history (editor-command 'unbound-key-sequence editor
-                                               #:keyseq total-keyseq))
+                                                      #:keyseq total-keyseq)))
-               (loop '() '() (root-keyseq-handler editor) (request-repaint))
+             (message editor "Unbound key sequence: ~a" (keyseq->keyspec total-keyseq)))
-               (error 'editor-mainloop "Unbound key sequence: ~a"
+           (loop '() '() (root-keyseq-handler editor) (request-repaint))]
-                      (keyseq->keyspec total-keyseq)))]
           [(incomplete-key-sequence next-handler)
+           (message editor "~a-" (keyseq->keyspec total-keyseq))
            (wait-for-input next-handler)]
           [(command-invocation selector prefix-arg remaining-input)
            (define accepted-input
@@ -296,24 +309,50 @@
 
 (define (clear-message editor)
   (buffer-replace-contents! (editor-echo-area editor) (empty-rope))
+  (define re (editor-recursive-edit editor))
+  (when re (set-window-buffer! (editor-mini-window editor) re (buffer-size re)))
+  (set-editor-message-expiry-time! editor #f)
   (invalidate-layout! editor))
 
-(define (message editor fmt . args)
+(define (message #:duration [duration0 #f]
+                 editor fmt . args)
+  (define duration (or duration0 (and (editor-recursive-edit editor) 2)))
   (define msg (string->rope (apply format fmt args)))
+  (define echo-area (editor-echo-area editor))
   (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)
+  (buffer-replace-contents! echo-area msg)
+  (set-window-buffer! (editor-mini-window editor) echo-area (buffer-size echo-area))
   (invalidate-layout! editor)
+  (when duration
+    (set-editor-message-expiry-time! editor (+ (current-inexact-milliseconds) (* duration 1000.0))))
   (render-editor! editor))
 
-(define (abort #:detail [detail #f] fmt . args)
+(define (start-recursive-edit editor buf)
-  (raise (exn:abort (apply format fmt args)
+  (when (editor-recursive-edit editor)
-                    (current-continuation-marks)
+    (abort "Command attempted to use minibuffer while in minibuffer"))
-                    detail)))
+  (set-editor-recursive-edit! editor buf)
+  (define miniwin (editor-mini-window editor))
+  (set-window-buffer! miniwin buf (buffer-size buf))
+  (set-editor-windows! editor
+                       (circular-snoc (editor-windows editor)
+                                      (list miniwin (absolute-size 0))))
+  (set-editor-active-window! editor miniwin)
+  (invalidate-layout! editor))
+
+(define (abandon-recursive-edit editor)
+  (set-editor-recursive-edit! editor #f)
+  (define echo-area (editor-echo-area editor))
+  (define miniwin (editor-mini-window editor))
+  (set-window-buffer! miniwin echo-area (buffer-size echo-area))
+  (when (eq? (editor-active-window editor) miniwin)
+    (set-editor-active-window! editor (car (circular-car (editor-windows editor)))))
+  (update-window-entry editor miniwin (lambda (e) '()))
+  (invalidate-layout! editor))
 
 ;;---------------------------------------------------------------------------
 

rmacs/minibuf.rkt

@@ -0,0 +1,53 @@
+#lang racket/base
+
+(provide read-from-minibuffer
+         recursive-edit-field-start
+         recursive-edit-mode
+         recursive-edit-accept-hook
+         recursive-edit-cancel-hook)
+
+(require "buffer.rkt")
+(require "editor.rkt")
+(require "mode.rkt")
+(require "keys.rkt")
+(require "rope.rkt")
+
+(define (read-from-minibuffer editor
+                              prompt
+                              #:on-accept k-accept
+                              #:on-cancel [k-cancel void])
+  (define buf (make-buffer #f "*minibuf*"))
+  (configure-fresh-buffer! editor buf)
+  (buffer-add-mode! buf recursive-edit-mode)
+  (buffer-replace-contents! buf (string->rope prompt))
+  (buffer-mark! buf recursive-edit-field-start (buffer-size buf))
+  (recursive-edit-selected-window buf (editor-active-window editor))
+  (recursive-edit-accept-hook buf k-accept)
+  (recursive-edit-cancel-hook buf k-cancel)
+  (start-recursive-edit editor buf)
+  buf)
+
+(define recursive-edit-field-start (mark-type (buffer-mark-type 'recursive-edit-field-start
+                                                                '*minibuf*
+                                                                #t)
+                                              'left))
+
+(define recursive-edit-mode (make-mode "recursive-edit"))
+
+(define-buffer-local recursive-edit-selected-window)
+(define-buffer-local recursive-edit-accept-hook (lambda (content) (void)))
+(define-buffer-local recursive-edit-cancel-hook (lambda () (void)))
+
+(define-command recursive-edit-mode (abort-recursive-edit buf #:editor ed)
+  #:bind-key "C-g"
+  (abandon-recursive-edit ed)
+  (select-window ed (recursive-edit-selected-window buf))
+  ((recursive-edit-cancel-hook buf)))
+
+(define-command recursive-edit-mode (exit-minibuffer buf #:editor ed)
+  #:bind-key "C-m"
+  #:bind-key "C-j"
+  (abandon-recursive-edit ed)
+  (select-window ed (recursive-edit-selected-window buf))
+  ((recursive-edit-accept-hook buf)
+   (rope->string (buffer-region buf recursive-edit-field-start (buffer-size buf)))))

rmacs/mode/fundamental.rkt

@@ -60,27 +60,27 @@
 
 (define-buffer-local last-vertical-movement-preferred-column)
 
-(define (vertical-movement-preferred-column win)
+(define (vertical-movement-preferred-column editor win)
   (define buf (window-buffer win))
   (last-vertical-movement-preferred-column
    buf
-   (or (and (editor-last-command? (buffer-editor buf)
+   (or (and (editor-last-command? editor
                                   'next-line
                                   'prev-line)
             (last-vertical-movement-preferred-column buf))
        (buffer-column buf (window-point win)))))
 
-(define-command fundamental-mode (next-line buf #:window win #:prefix-arg [count 1])
+(define-command fundamental-mode (next-line buf #:window win #:editor ed #:prefix-arg [count 1])
   #:bind-key "C-n"
   #:bind-key "<down>"
-  (define col (vertical-movement-preferred-column win))
+  (define col (vertical-movement-preferred-column ed win))
   (move-forward-n-lines win count)
   (move-to-column win col))
 
-(define-command fundamental-mode (prev-line buf #:window win #:prefix-arg [count 1])
+(define-command fundamental-mode (prev-line buf #:window win #:editor ed #:prefix-arg [count 1])
   #:bind-key "C-p"
   #:bind-key "<up>"
-  (define col (vertical-movement-preferred-column win))
+  (define col (vertical-movement-preferred-column ed win))
   (move-backward-n-lines win count)
   (move-to-column win col))
 
@@ -161,3 +161,12 @@
 (define-command fundamental-mode (save-buffer buf)
   #:bind-key "C-x C-s"
   (save-buffer! buf))
+
+(define-command fundamental-mode (execute-extended-command buf #:command cmd #:editor ed)
+  #:bind-key "M-x"
+  (read-from-minibuffer ed "M-x "
+                        #:on-accept (lambda (content)
+                                      (define selector (string->symbol content))
+                                      (invoke (copy-command cmd
+                                                            #:selector (string->symbol content)
+                                                            #:keyseq #f)))))

rmacs/render.rkt

@@ -145,6 +145,8 @@
   (append (let loop ((ws ws) (offset 0) (remaining proportional-lines))
             (match ws
               ['() '()]
+              [(cons (list (== miniwin eq?) _) rest)
+               (loop rest offset remaining)]
               [(cons (list w (and spec (absolute-size lines))) rest)
                (cons (layout w spec offset 0 total-width lines)
                      (loop rest (+ offset lines) remaining))]

rmacs/window.rkt

@@ -49,9 +49,14 @@
   (void))
 
 (define (window-command selector window
+                        #:editor [editor #f]
                         #:keyseq [keyseq #f]
                         #:prefix-arg [prefix-arg '#:default])
-  (command selector (window-buffer window) #:window window #:keyseq keyseq #:prefix-arg prefix-arg))
+  (command selector (window-buffer window)
+           #:window window
+           #:editor editor
+           #:keyseq keyseq
+           #:prefix-arg prefix-arg))
 
 (define (window-mark! win [pos (window-point win)])
   (buffer-mark! (window-buffer win) (window-mark win) pos)