Re: find-file-project

[Stefan Monnier]

> Were you going to attach it?

I was, yes.

>> Not sure in general (e.g. for attributes), but for tag names at least,
>> I think that's pretty much the case.
> Attribute values could be a problem,

Haven't thought much about them, but I don't think so: they tend to
either have few variants or offer no completion at all (allow
pretty much anything).

> but why not in attribute names?

Yes, for attribute names that's pretty much the case as well I think.

> Do we expect to work with freakish schemas, with thousands of
> possible attributes?

Sounds unlikely.

>>> But that's a bit of a separate concern: since completion-try-completion and
>>> completion-all-completions are on a higher level, I think *they* could be
>>> generics, whereas the all-completions/etc could stay as they are.
>> But the only argument they receive is the completion-table, so we need
>> them to be "dispatchable".
> They who? completion-try-completion and the other?

Yes.

> The default method will handle lists/alists/hash-tables and
> functions.  The specialized methods will handle "dispatchable" types.

Right, but that still requires the a new "dispatchable" kind of
completion-table.

>> [ Side note: I've been toying with the idea of "callable objects", by
>> which I mean thingies which have slots and dispatchable types (like
>> cl-structs or eieio objects) but which can also be passed to funcall.
>> We could use them for the advice objects of nadvice.el, for the stream
>> objects of stream.el, and potentially here as well.  ]
> Like a closure, but with named fields as its environment? I can see how it
> could be handy for debugging, but not how it would help with the issue
> at hand.

That would allow us to keep using functions (rather than add a new kind
of completion-table), and simply give them a dispatchable type when we
need it.


        Stefan


diff --git a/lisp/filecache.el b/lisp/filecache.el
index e754190..56b7f43 100644
--- a/lisp/filecache.el
+++ b/lisp/filecache.el
@@ -1,4 +1,4 @@
-;;; filecache.el --- find files using a pre-loaded cache
+;;; filecache.el --- Find files using a pre-loaded cache  -*- lexical-binding: 
t -*-
 
 ;; Copyright (C) 1996, 2000-2016 Free Software Foundation, Inc.
 
@@ -499,7 +499,7 @@ If called interactively, read the directory names one by 
one."
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 ;; Returns the name of a directory for a file in the cache
-(defun file-cache-directory-name  (file)
+(defun file-cache-directory-name (file)
   (let* ((directory-list (cdr (assoc-string
                               file file-cache-alist
                               file-cache-ignore-case)))
@@ -517,8 +517,11 @@ If called interactively, read the directory names one by 
one."
       (error "Filecache: no directory found for key %s" file))
      ;; Multiple elements
      (t
+      ;; FIXME: the use of minibuffer-contents here means that
+      ;; filecache can only be used in the minibuffer :-(
       (let* ((minibuffer-dir (file-name-directory (minibuffer-contents)))
-            (dir-list       (member minibuffer-dir directory-list)))
+            (dir-list       (member (expand-file-name minibuffer-dir)
+                                     directory-list)))
        (setq directory
              ;; If the directory is in the list, return the next element
              ;; Otherwise, return the first element
@@ -533,9 +536,9 @@ If called interactively, read the directory names one by 
one."
     directory))
 
 ;; Returns the name of a file in the cache
-(defun file-cache-file-name  (file)
+(defun file-cache-file-name (file)
   (let ((directory (file-cache-directory-name file)))
-    (concat directory file)))
+    (abbreviate-file-name (concat directory file))))
 
 ;; Return a canonical directory for comparison purposes.
 ;; Such a directory ends with a forward slash.
@@ -557,78 +560,151 @@ If called interactively, read the directory names one by 
one."
 ;;
 ;; The default is to do the former; a prefix arg forces the latter.
 
+(defun file-cache-minibuffer-message (msg)
+  ;; Can't output a minibuffer-message naively from the
+  ;; completion-table because the completion hasn't been performed
+  ;; yet, so the sit-for would do the wrong thing.
+  ;; (minibuffer-message file-cache-multiple-directory-message)
+  (let ((buf (current-buffer))
+        (ol (if (minibufferp (current-buffer))
+                (make-overlay (point-max) (point-max)
+                              nil t t)))
+        (timer ())
+        (fun ()))
+    (if (null ol)
+        (message msg)
+      (unless (zerop (length msg))
+        ;; The current C cursor code doesn't know to use the overlay's
+        ;; marker's stickiness to figure out whether to place the cursor
+        ;; before or after the string, so let's spoon-feed it the pos.
+        (setq msg (copy-sequence msg))
+        (put-text-property 0 1 'cursor t msg))
+      (overlay-put ol 'after-string msg))
+    (setq fun (lambda ()
+                (with-current-buffer buf
+                  (if (overlay-buffer ol)
+                      (delete-overlay ol)
+                    (message nil))
+                  (when timer (cancel-timer timer) (setq timer nil))
+                  (remove-hook 'pre-command-hook fun 'local))))
+    (add-hook 'pre-command-hook fun nil 'local)
+    (when minibuffer-message-timeout
+      (setq timer (run-with-timer minibuffer-message-timeout nil fun)))))
+
+(defun file-cache-completion-table (minibuffer-contents pred action)
+  (let* ((completion-ignore-case file-cache-completion-ignore-case)
+         (case-fold-search       file-cache-case-fold-search)
+         (string                 (file-name-nondirectory minibuffer-contents))
+         ;; Ignore completion-regexp-list since it applies to the complete
+         ;; filenames, where here we're mostly just handling the
+         ;; nondirectory parts.
+         (completion-regexp-list nil)
+         ;; First look at the nondirectory part.
+         (completion-string (try-completion string file-cache-alist))
+         (dirs (assoc-string (if (stringp completion-string)
+                                 completion-string string)
+                             file-cache-alist file-cache-ignore-case)))
+    (cond
+     ;; If it's an exact match, complete on the directories by cycling.
+     ((or current-prefix-arg (eq completion-string t)
+          (and (equal string completion-string) dirs
+               ;; FIXME: This use of this/last-command to decide
+               ;; whether to start cycling or not is an ugly
+               ;; hack.  Previous code used a global
+               ;; `file-cache-last-completion' var, but that
+               ;; doesn't work now that we're in a completion
+               ;; table that can be called several times
+               ;; for a single completion command.
+               (setq this-command 'file-cache-complete-but-no-unique)
+               (eq last-command this-command))
+          ;; Also start cycling right away if there's only one
+          ;; completion for the filename part.
+
+          ;; FIXME: this has one bug, which was already present in the
+          ;; old code, in that if the current file is already in the
+          ;; first dir, we skip straight to the second.
+          ;; Then again, maybe this is a feature, tho, since the user
+          ;; could have used normal completion if he wanted the file
+          ;; in the current dir.
+          (and completion-string
+               (eq t (try-completion completion-string file-cache-alist))))
+      (if (eq completion-string t) (setq completion-string string))
+      (let ((file-cache-string (file-cache-file-name completion-string)))
+        (cond
+         ;; FIXME: to cycle, we have to behave in a non-standard way,
+         ;; e.g. the list of completions returned for all-completions
+         ;; will mostly not match the given "prefix".
+         ;; Instead, we should have a way for the completion table to
+         ;; say "use cycling now" or "this completion table is not
+         ;; prefix-based".  This will imply things like "don't use
+         ;; partial matching".
+         ;; Return the next directory.
+         ((eq action nil)
+          (cond
+           ((string= file-cache-string minibuffer-contents) t)
+           (current-prefix-arg
+            ;; By returning the same string, we hopefully cause
+            ;; minibuffer-complete to call minibuffer-completion-help.
+            ;; But subsequent completions will then try to scroll that
+            ;; window unless we change this-command.
+            (setq this-command 'file-cache-completion-help)
+            ;; To make sure we show completion-help even if
+            ;; completion-auto-help is `lazy', we also set
+            ;; last-command.
+            (setq last-command 'file-cache-completion-help)
+            minibuffer-contents)
+           (t
+            (when file-cache-multiple-directory-message
+              (file-cache-minibuffer-message
+               file-cache-multiple-directory-message))
+            file-cache-string)))
+         (t
+          ;; FIXME: if action is t (i.e. all-completions), we
+          ;; return a list of completions which don't match the
+          ;; prefix.  This is necessary for the completion-help to display
+          ;; the actual list of possible directories, but it also has
+          ;; some undesirable side-effects.  E.g. completion-help will
+          ;; tend to assume that the returned completions match the
+          ;; prefix and will blindly highlight the "following" char.
+          (complete-with-action
+           action
+           (mapcar (lambda (d) (abbreviate-file-name
+                           (concat d completion-string)))
+                   (cdr dirs))
+           (if (or (not (memq action '(t)))
+                   (string= file-cache-string minibuffer-contents))
+               minibuffer-contents "")
+           pred)))))
+
+     ;; We don't want to cycle, instead do normal completion on the
+     ;; filename part.  Here partial-completion and friends should
+     ;; work just fine.  We could even make `initials' completion
+     ;; working there.
+     (t
+      (completion-table-with-context
+       (or (file-name-directory minibuffer-contents) "")
+       ;; Ignore the predicate here since this is only an intermediate
+       ;; state where we complete file names that will usually not be yet
+       ;; in the right directory.
+       file-cache-alist string nil action)))))
+
 ;;;###autoload
-(defun file-cache-minibuffer-complete (arg)
+(defun file-cache-minibuffer-complete (_arg)
   "Complete a filename in the minibuffer using a preloaded cache.
 Filecache does two kinds of substitution: it completes on names in
 the cache, and, once it has found a unique name, it cycles through
-the directories that the name is available in.  With a prefix argument,
-the name is considered already unique; only the second substitution
-\(directories) is done."
+the directories that the name is available in."
   (interactive "P")
-  (let*
-      (
-       (completion-ignore-case file-cache-completion-ignore-case)
-       (case-fold-search       file-cache-case-fold-search)
-       (string                 (file-name-nondirectory (minibuffer-contents)))
-       (completion-string      (try-completion string file-cache-alist))
-       (completion-list)
-       (len)
-       (file-cache-string))
-    (cond
-     ;; If it's the only match, replace the original contents
-     ((or arg (eq completion-string t))
-      (setq file-cache-string (file-cache-file-name string))
-      (if (string= file-cache-string (minibuffer-contents))
-         (minibuffer-message file-cache-sole-match-message)
-       (delete-minibuffer-contents)
-       (insert file-cache-string)
-       (if file-cache-multiple-directory-message
-           (minibuffer-message file-cache-multiple-directory-message))))
-
-     ;; If it's the longest match, insert it
-     ((stringp completion-string)
-      ;; If we've already inserted a unique string, see if the user
-      ;; wants to use that one
-      (if (and (string= string completion-string)
-              (assoc-string string file-cache-alist
-                            file-cache-ignore-case))
-         (if (and (eq last-command this-command)
-                  (string= file-cache-last-completion completion-string))
-             (progn
-               (delete-minibuffer-contents)
-               (insert (file-cache-file-name completion-string))
-               (setq file-cache-last-completion nil))
-           (minibuffer-message file-cache-non-unique-message)
-           (setq file-cache-last-completion string))
-       (setq file-cache-last-completion string)
-       (setq completion-list (all-completions string file-cache-alist)
-             len             (length completion-list))
-       (if (> len 1)
-           (progn
-             (goto-char (point-max))
-             (insert
-              (substring completion-string (length string)))
-             ;; Add our own setup function to the Completions Buffer
-             (let ((completion-setup-hook
-                     (append completion-setup-hook
-                             (list 'file-cache-completion-setup-function))))
-               (with-output-to-temp-buffer file-cache-completions-buffer
-                 (display-completion-list
-                   (completion-hilit-commonality completion-list
-                                                 (length string))))))
-         (setq file-cache-string (file-cache-file-name completion-string))
-         (if (string= file-cache-string (minibuffer-contents))
-             (minibuffer-message file-cache-sole-match-message)
-           (delete-minibuffer-contents)
-           (insert file-cache-string)
-           (if file-cache-multiple-directory-message
-               (minibuffer-message file-cache-multiple-directory-message)))
-         )))
-
-     ;; No match
-     ((eq completion-string nil)
-      (minibuffer-message file-cache-no-match-message)))))
+  (let ((minibuffer-completion-table 'file-cache-completion-table)
+        ;; When cycling, partial completion doesn't work at all.
+        (completion-styles (if (eq 'partial-completion (car completion-styles))
+                               (cons 'basic completion-styles)
+                             completion-styles))
+        (completion-setup-hook
+         (append completion-setup-hook
+                 (list 'file-cache-completion-setup-function))))
+    ;; FIXME: Use completion-in-region?
+    (minibuffer-complete)))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Completion functions
@@ -636,7 +712,14 @@ the name is considered already unique; only the second 
substitution
 
 (defun file-cache-completion-setup-function  ()
   (with-current-buffer standard-output ;; i.e. file-cache-completions-buffer
-    (use-local-map file-cache-completions-keymap)))
+    (if (save-excursion
+          (goto-char (point-min))
+          (next-completion 1)
+          (file-name-absolute-p
+           (buffer-substring (point) (line-end-position))))
+        ;; FIXME: we could strip the bogus highlighting here, actually.
+        nil
+      (use-local-map file-cache-completions-keymap))))
 
 (defun file-cache-choose-completion (&optional event)
   "Choose a completion in the `*Completions*' buffer."