diff --git a/rmacs/api.rkt b/rmacs/api.rkt index 2f91ab1..eeb68e6 100644 --- a/rmacs/api.rkt +++ b/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")) diff --git a/rmacs/buffer.rkt b/rmacs/buffer.rkt index 06700e8..f21dda3 100644 --- a/rmacs/buffer.rkt +++ b/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)) diff --git a/rmacs/editor.rkt b/rmacs/editor.rkt index 16a46e9..ddfd643 100644 --- a/rmacs/editor.rkt +++ b/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) - abort) + start-recursive-edit + 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 - #:keyseq total-keyseq)) - (loop '() '() (root-keyseq-handler editor) (request-repaint)) - (error 'editor-mainloop "Unbound key sequence: ~a" - (keyseq->keyspec total-keyseq)))] + (when (not (invoke/history (editor-command 'unbound-key-sequence editor + #:keyseq total-keyseq))) + (message editor "Unbound key sequence: ~a" (keyseq->keyspec total-keyseq))) + (loop '() '() (root-keyseq-handler editor) (request-repaint))] [(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) - (raise (exn:abort (apply format fmt args) - (current-continuation-marks) - detail))) +(define (start-recursive-edit editor buf) + (when (editor-recursive-edit editor) + (abort "Command attempted to use minibuffer while in minibuffer")) + (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)) ;;--------------------------------------------------------------------------- diff --git a/rmacs/minibuf.rkt b/rmacs/minibuf.rkt new file mode 100644 index 0000000..8adfcbc --- /dev/null +++ b/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))))) diff --git a/rmacs/mode/fundamental.rkt b/rmacs/mode/fundamental.rkt index 21014fe..2a523f9 100644 --- a/rmacs/mode/fundamental.rkt +++ b/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 "" - (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 "" - (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))))) diff --git a/rmacs/render.rkt b/rmacs/render.rkt index e302caf..dfad741 100644 --- a/rmacs/render.rkt +++ b/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))] diff --git a/rmacs/window.rkt b/rmacs/window.rkt index c9a20da..657d19d 100644 --- a/rmacs/window.rkt +++ b/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)