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

recursive editing and M-x

This commit is contained in:
Tony Garnock-Jones 2014-12-28 17:59:05 -05:00
parent 0b6e827e70
commit 1090700bac
7 changed files with 156 additions and 33 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
rmacs/api.rkt
View File

@ -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"))

23
rmacs/buffer.rkt
View File

@ -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))

79
rmacs/editor.rkt
View File

@ -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))
;;---------------------------------------------------------------------------

53
rmacs/minibuf.rkt Normal file
View File

@ -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)))))

21
rmacs/mode/fundamental.rkt
View File

@ -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)))))

2
rmacs/render.rkt
View File

@ -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))]

7
rmacs/window.rkt
View File

@ -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)