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

Completion

This commit is contained in:
Tony Garnock-Jones 2014-12-28 19:18:01 -05:00
parent 1090700bac
commit 55f9dc864a
5 changed files with 145 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
rmacs/editor.rkt
View File

@ -185,8 +185,9 @@
(and w (window-buffer w)))
(define (editor-active-modeset editor)
(define b (editor-active-buffer editor))
(and b (buffer-modeset b)))
(let* ((b (editor-active-buffer editor))
(b (if (eq? b (editor-echo-area editor)) (editor-recursive-edit editor) b)))
(and b (buffer-modeset b))))
(define (editor-next-window editor win)
(cond [(circular-list-memf (entry-for? win)
@ -212,7 +213,6 @@
(define (invoke/history cmd)
(define editor (command-editor cmd))
(clear-message editor)
(with-handlers* ([exn:abort? (lambda (e)
(message editor "~a" (exn-message e)
#:duration (exn:abort-duration e))
@ -269,6 +269,7 @@
(handle-evt (tty-next-key-evt (editor-tty editor))
(lambda (new-key)
(define new-input (list new-key))
(clear-message editor)
(loop (append total-keyseq new-input)
new-input
next-handler
@ -308,11 +309,13 @@
(invalidate-layout! editor))
(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))
(when (positive? (buffer-size (editor-echo-area editor)))
(buffer-replace-contents! (editor-echo-area editor) (empty-rope))
(define re (editor-recursive-edit editor))
(when (and re (not (eq? (window-buffer (editor-mini-window editor)) re)))
(set-window-buffer! (editor-mini-window editor) re (buffer-size re)))
(set-editor-message-expiry-time! editor #f)
(invalidate-layout! editor)))
(define (message #:duration [duration0 #f]
editor fmt . args)

103
rmacs/minibuf.rkt
View File

@ -4,16 +4,27 @@
recursive-edit-field-start
recursive-edit-mode
recursive-edit-accept-hook
recursive-edit-cancel-hook)
recursive-edit-cancel-hook
completing-read
simple-completion
completing-read-mode
completing-read-string=?-hook
completing-read-completion-hook
completing-read-acceptable-hook)
(require "buffer.rkt")
(require "editor.rkt")
(require "mode.rkt")
(require "keys.rkt")
(require "rope.rkt")
(require "window.rkt")
(require "strings.rkt")
;;---------------------------------------------------------------------------
(define (read-from-minibuffer editor
prompt
#:initial [initial ""]
#:on-accept k-accept
#:on-cancel [k-cancel void])
(define buf (make-buffer #f "*minibuf*"))
@ -21,6 +32,7 @@
(buffer-add-mode! buf recursive-edit-mode)
(buffer-replace-contents! buf (string->rope prompt))
(buffer-mark! buf recursive-edit-field-start (buffer-size buf))
(buffer-insert! buf (buffer-size buf) (string->rope initial))
(recursive-edit-selected-window buf (editor-active-window editor))
(recursive-edit-accept-hook buf k-accept)
(recursive-edit-cancel-hook buf k-cancel)
@ -44,10 +56,95 @@
(select-window ed (recursive-edit-selected-window buf))
((recursive-edit-cancel-hook buf)))
(define (recursive-edit-contents buf)
(rope->string (buffer-region buf recursive-edit-field-start (buffer-size 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)))))
((recursive-edit-accept-hook buf) (recursive-edit-contents buf)))
(define-command recursive-edit-mode (minibuf-beginning-of-line buf #:window win)
#:bind-key "C-a"
#:bind-key "<home>"
(define limit (buffer-mark-pos* buf recursive-edit-field-start))
(if (and limit (> (buffer-mark-pos buf (window-point win)) limit))
(window-move-to! win limit)
(buffer-move-mark-to-start-of-line! buf (window-point win))))
;;---------------------------------------------------------------------------
(define (completing-read editor
prompt
completion-fn
#:string=? [string=? string=?]
#:initial [initial ""]
#:acceptable? [acceptable? (lambda (v) #t)]
#:on-accept k-accept
#:on-cancel [k-cancel void])
(define buf (read-from-minibuffer editor prompt
#:initial initial
#:on-accept k-accept
#:on-cancel k-cancel))
(buffer-add-mode! buf completing-read-mode)
(completing-read-string=?-hook buf string=?)
(completing-read-completion-hook buf completion-fn)
(completing-read-acceptable-hook buf acceptable?)
buf)
(define (simple-completion collection)
(define collection-strings (for/list ((c collection)) (format "~a" c)))
(lambda (prefix string=?)
(for/list ((c collection-strings) #:when (string-prefix? prefix c string=?)) c)))
(define completing-read-mode (make-mode "completing"))
(define-buffer-local completing-read-string=?-hook
string=?)
(define-buffer-local completing-read-completion-hook
(lambda (v) (abort "completing-read-completion-hook not set")))
(define-buffer-local completing-read-acceptable-hook
(lambda (v) #t))
(define (common-string-prefix strs string=?)
(if (null? (cdr strs))
(car strs)
(let ((len (let loop ((i 1))
(if (for/and ((c (cdr strs)))
(and (>= (string-length c) i)
(string=? (substring (car strs) 0 i) (substring c 0 i))))
(loop (+ i 1))
(- i 1)))))
(substring (car strs) 0 len))))
(define-command completing-read-mode (minibuffer-complete buf #:editor ed)
#:bind-key "C-i"
#:bind-key "tab"
(define string=? (completing-read-string=?-hook buf))
(define prefix (recursive-edit-contents buf))
(define unfiltered-completions ((completing-read-completion-hook buf) prefix string=?))
(define completions (filter (lambda (s) (string-prefix? prefix s string=?))
unfiltered-completions))
(when (pair? completions)
(define common-prefix (common-string-prefix completions string=?))
(define complete? (null? (cdr completions)))
(if (string=? common-prefix prefix)
;; No progress.
(if complete?
(message ed "Sole completion")
(message ed "Completions: ~a" completions))
;; Some progress
(buffer-region-update! buf
recursive-edit-field-start
(buffer-size buf)
(lambda (_old)
(string->rope common-prefix))))))
(define-command completing-read-mode (exit-minibuffer buf
#:next-method next-method
#:command cmd
#:editor ed)
(when ((completing-read-acceptable-hook buf) (recursive-edit-contents buf))
(next-method cmd)))

9
rmacs/mode.rkt
View File

@ -16,6 +16,7 @@
mode-define-command!
mode-undefine-command!
mode-redefine-command!
mode-command-selectors
make-modeset
modeset-add-mode
@ -23,6 +24,7 @@
modeset-toggle-mode
modeset-keyseq-handler
modeset-lookup-command
modeset-command-selectors
kernel-mode
kernel-modeset)
@ -114,6 +116,9 @@
(define (mode-redefine-command! m selector handler)
(mode-define-command! (mode-undefine-command! m selector) selector handler))
(define (mode-command-selectors m)
(list->seteq (hash-keys (mode-commands m))))
(define (make-modeset)
(modeset (hasheq)
'()
@ -197,6 +202,10 @@
(when next-method (next-method cmd)))))
(search rest))])))
(define (modeset-command-selectors ms)
(for/fold [(selectors (seteq))] [(m (hash-values (modeset-modes ms)))]
(set-union selectors (mode-command-selectors m))))
(define kernel-mode
(mode-add-constraints (make-raw-mode "kernel")
#:dispatch-keys-after '(#:kernel)

13
rmacs/mode/fundamental.rkt
View File

@ -164,9 +164,10 @@
(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)))))
(completing-read ed "M-x "
(simple-completion (modeset-command-selectors (buffer-modeset buf)))
#:on-accept (lambda (content)
(define selector (string->symbol content))
(invoke (copy-command cmd
#:selector (string->symbol content)
#:keyseq #f)))))

18
rmacs/strings.rkt Normal file
View File

@ -0,0 +1,18 @@
#lang racket/base
;; String utilities :-(
(provide string-prefix?)
(define (string-prefix? a b [string=? string=?])
(define a-len (string-length a))
(and (>= (string-length b) a-len)
(string=? (substring b 0 a-len) a)))
(module+ test
(require rackunit)
(check-true (string-prefix? "aaa" "aaaa"))
(check-false (string-prefix? "aaaa" "aaa"))
(check-false (string-prefix? "a" "z"))
(check-false (string-prefix? "z" "a"))
(check-true (string-prefix? "a" "a"))
)