Implement generic support for completions.

diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg
index c434db0181fba03faee513a5a09474d591207c6e..465195c0b998bcb83b6dc0bd2e2af58b95e6014f 100644 (file)
--- a/v7/src/edwin/edwin.pkg
+++ b/v7/src/edwin/edwin.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.41 1991/05/20 19:41:50 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.42 1991/05/21 02:05:04 cph Exp $
 
 Copyright (c) 1989-91 Massachusetts Institute of Technology
 
@@ -448,6 +448,7 @@ MIT in each case. |#
   (files "prompt")
   (parent (edwin))
   (export (edwin)
+         completion-message
          edwin-command$exit-minibuffer
          edwin-command$exit-minibuffer-yes-or-no
          edwin-command$minibuffer-complete
@@ -466,6 +467,8 @@ MIT in each case. |#
          edwin-variable$enable-recursive-minibuffers
          edwin-variable$completion-auto-help
          initialize-typein!
+         pop-up-completions-list
+         pop-up-generated-completions
          prompt-for-alist-value
          prompt-for-char
          prompt-for-command
@@ -480,6 +483,8 @@ MIT in each case. |#
          prompt-for-typein
          prompt-for-variable
          prompt-for-yes-or-no?
+         standard-completion
+         temporary-typein-message
          typein-edit-other-window
          within-typein-edit
          within-typein-edit?

diff --git a/v7/src/edwin/prompt.scm b/v7/src/edwin/prompt.scm
index 44f66996c2dfd0e728f7e2a02635ea7623dc8bd5..8881f32348b1fff22bdd8d06f224b8ce0395f698 100644 (file)
--- a/v7/src/edwin/prompt.scm
+++ b/v7/src/edwin/prompt.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.145 1991/05/18 03:11:46 cph Exp $
+;;;    $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/prompt.scm,v 1.146 1991/05/21 02:04:36 cph Exp $
 ;;;
 ;;;    Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology
 ;;;
@@ -133,22 +133,24 @@
           (not (ref-variable enable-recursive-minibuffers))
           (typein-window? (current-window)))
       (editor-error "Command attempted to use minibuffer while in minibuffer"))
-  (within-typein-edit
+  (cleanup-pop-up-buffers
    (lambda ()
-     (insert-string prompt-string)
-     (let ((mark (current-point)))
-       (with-text-clipped (mark-right-inserting mark)
-                         (mark-left-inserting mark)
-        (lambda ()
-          (intercept-^G-interrupts
+     (within-typein-edit
+      (lambda ()
+       (insert-string prompt-string)
+       (let ((mark (current-point)))
+         (with-text-clipped (mark-right-inserting mark)
+                            (mark-left-inserting mark)
            (lambda ()
-             (cond ((not (eq? (current-window) (typein-window)))
-                    (abort-current-command))
-                   (typein-edit-continuation
-                    (typein-edit-continuation typein-edit-abort-flag))
-                   (else
-                    (error "illegal ^G signaled in typein window"))))
-           thunk)))))))
+             (intercept-^G-interrupts
+              (lambda ()
+                (cond ((not (eq? (current-window) (typein-window)))
+                       (abort-current-command))
+                      (typein-edit-continuation
+                       (typein-edit-continuation typein-edit-abort-flag))
+                      (else
+                       (error "illegal ^G signaled in typein window"))))
+              thunk)))))))))
 
 (define ((typein-editor-thunk mode))
   (let ((buffer (current-buffer)))
@@ -179,24 +181,6 @@
 (define (update-typein!)
     (if (not *executing-keyboard-macro?*)
        (window-direct-update! (typein-window) false)))
-
-(define (temporary-typein-message string)
-  (let ((point) (start) (end))
-    (dynamic-wind (lambda ()
-                   (set! point (current-point))
-                   (set! end (buffer-end (current-buffer)))
-                   (set! start (mark-right-inserting end))
-                   (insert-string string start)
-                   (set-current-point! start))
-                 (lambda ()
-                   (sit-for 2000))
-                 (lambda ()
-                   (delete-string start end)
-                   (set-current-point! point)
-                   (set! point)
-                   (set! start)
-                   (set! end)
-                   unspecific))))
 \f
 ;;;; String Prompt
 
@@ -231,13 +215,11 @@
              (completion-procedure/list-completions list-completions)
              (completion-procedure/verify-final-value? verify-final-value?)
              (*completion-confirm?* (not (eq? require-match? true))))
-    (cleanup-pop-up-buffers
-     (lambda ()
-       (%prompt-for-string
-       prompt
-       (if require-match?
-           (ref-mode-object minibuffer-local-must-match)
-           (ref-mode-object minibuffer-local-completion)))))))
+    (%prompt-for-string
+     prompt
+     (if require-match?
+        (ref-mode-object minibuffer-local-must-match)
+        (ref-mode-object minibuffer-local-completion)))))
 
 (define (%prompt-for-string prompt mode)
   (prompt-for-typein
@@ -446,17 +428,9 @@ The following commands are special to this mode:
        (completion-procedure/list-completions (typein-string))))))
 
 (define (minibuffer-completion-help list-completions)
-  (let ((window (typein-window)))
-    (window-set-override-message! window "Making completion list...")
-    (window-direct-update! window true)
-    (let ((completions (list-completions)))
-      (window-clear-override-message! window)
-      (if (null? completions)
-         (begin
-          (editor-beep)
-          (temporary-typein-message " [No completions]"))
-         (write-completions-list
-          (map map-name/internal->external completions))))))
+  (pop-up-generated-completions
+   (lambda ()
+     (map map-name/internal->external (list-completions)))))
 
 (define-command minibuffer-complete-and-exit
   "Complete the minibuffer contents, and maybe exit.
@@ -513,16 +487,6 @@ a repetition of this command will exit."
        (temporary-typein-message " [No match]")
        'NO-MATCH))))
 
-(define (write-completions-list strings)
-  (with-output-to-temporary-buffer " *Completions*"
-    (lambda ()
-      (if (null? strings)
-         (write-string
-          "There are no possible completions of what you have typed.")
-         (begin
-           (write-string "Possible completions are:\n")
-           (write-strings-densely strings))))))
-\f
 (define (completion-procedure/complete-word string
                                            if-unique
                                            if-not-unique
@@ -573,6 +537,82 @@ a repetition of this command will exit."
              (if-not-unique new-string list-completions)))
        if-not-found))))
 \f
+;;;; Support for Completion
+
+(define (standard-completion prefix complete-string insert-completed-string)
+  (complete-string prefix
+    (lambda (completion)
+      (if (not (string=? prefix completion))
+         (insert-completed-string completion)
+         (completion-message "Sole completion")))
+    (lambda (completion generate-completions)
+      (cond ((not (string=? prefix completion))
+            (insert-completed-string completion))
+           ((ref-variable completion-auto-help)
+            (pop-up-generated-completions generate-completions))
+           (else
+            (completion-message "Next char not unique"))))
+    (lambda ()
+      (editor-beep)
+      (completion-message "No completions"))))
+
+(define (pop-up-generated-completions generate-completions)
+  (message "Making completion list...")
+  (let ((completions (generate-completions)))
+    (clear-message)
+    (if (null? completions)
+       (begin
+         (editor-beep)
+         (completion-message "No completions"))
+       (begin
+         (pop-up-completions-list completions)
+         (if (not (typein-window? (current-window)))
+             (begin
+               (message "Hit space to flush.")
+               (reset-command-prompt!)
+               (let ((char (keyboard-peek-char)))
+                 (if (char=? #\space char)
+                     (begin
+                       (keyboard-read-char)
+                       (kill-pop-up-buffer false))))
+               (clear-message)))))))
+
+(define (pop-up-completions-list strings)
+  (with-output-to-temporary-buffer " *Completions*"
+    (lambda ()
+      (write-completions-list strings))))
+
+(define (write-completions-list strings)
+  (if (null? strings)
+      (write-string
+       "There are no possible completions of what you have typed.")
+      (begin
+       (write-string "Possible completions are:\n")
+       (write-strings-densely strings))))
+
+(define (completion-message string)
+  (if (typein-window? (current-window))
+      (temporary-typein-message (string-append " [" string "]"))
+      (message string)))
+
+(define (temporary-typein-message string)
+  (let ((point) (start) (end))
+    (dynamic-wind (lambda ()
+                   (set! point (current-point))
+                   (set! end (buffer-end (current-buffer)))
+                   (set! start (mark-right-inserting end))
+                   (insert-string string start)
+                   (set-current-point! start))
+                 (lambda ()
+                   (sit-for 2000))
+                 (lambda ()
+                   (delete-string start end)
+                   (set-current-point! point)
+                   (set! point)
+                   (set! start)
+                   (set! end)
+                   unspecific))))
+\f
 ;;;; Character Prompts
 
 (define (prompt-for-char prompt)