Completion

rmacs/editor.rkt

@@ -185,8 +185,9 @@
   (and w (window-buffer w)))
 
 (define (editor-active-modeset editor)
-  (define b (editor-active-buffer editor))
+  (let* ((b (editor-active-buffer editor))
-  (and b (buffer-modeset b)))
+         (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))
+  (when (positive? (buffer-size (editor-echo-area editor)))
-  (define re (editor-recursive-edit editor))
+    (buffer-replace-contents! (editor-echo-area editor) (empty-rope))
-  (when re (set-window-buffer! (editor-mini-window editor) re (buffer-size re)))
+    (define re (editor-recursive-edit editor))
-  (set-editor-message-expiry-time! editor #f)
+    (when (and re (not (eq? (window-buffer (editor-mini-window editor)) re)))
-  (invalidate-layout! editor))
+      (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)

rmacs/minibuf.rkt

@@ -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)
+  ((recursive-edit-accept-hook buf) (recursive-edit-contents buf)))
-   (rope->string (buffer-region buf recursive-edit-field-start (buffer-size 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)))

rmacs/mode.rkt

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

rmacs/mode/fundamental.rkt

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

rmacs/strings.rkt

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