diff --git a/README.org b/README.org index 2532294..5135cdc 100644 --- a/README.org +++ b/README.org @@ -545,7 +545,8 @@ Simple links may also be written manually in either sexp or non-sexp form, like: ** 0.7.1-pre -Nothing new yet. +*Fixes* ++ Function ~org-ql-completing-read~ is more compatible with default Emacs completion. (See [[https://github.com/alphapapa/org-ql/issues/338][#338]]. Thanks to [[https://github.com/arozbiz][arozbiz]] for reporting.) ** 0.7 diff --git a/org-ql-completing-read.el b/org-ql-completing-read.el index c661d45..b72c8fa 100644 --- a/org-ql-completing-read.el +++ b/org-ql-completing-read.el @@ -94,104 +94,190 @@ with commas to turn multiple tokens, which would normally be treated as multiple predicates, into multiple arguments to a single predicate)." (declare (indent defun)) - ;; Emacs's completion API is not always easy to understand, - ;; especially when using "programmed completion." This code was - ;; made possible by the example Clemens Radermacher shared at + ;; Emacs's completion API is not always easy to understand, especially when using "programmed + ;; completion." This code was made possible by the example Clemens Radermacher shared at ;; . + + ;; NOTE: I don't usually leave commented-out debugging code, but due to the incredibly tedious + ;; complexity of the "Programmed Completion" API and the time spent trying to get this reasonably + ;; close to "correct," I'm leaving it in, because I will undoubtedly have to go through this + ;; process again. + + ;; (message "ORG-QL-COMPLETING-READ: Starts.") (let ((table (make-hash-table :test #'equal)) + (disambiguations (make-hash-table :test #'equal)) (window-width (window-width)) - query-tokens snippet-regexp) - (cl-labels ((action + last-input org-outline-path-cache query-tokens snippet-regexp) + (cl-labels (;; (debug-message + ;; (f &rest args) (apply #'message (concat "ORG-QL-COMPLETING-READ: " f) args)) + (action () (font-lock-ensure (point-at-bol) (point-at-eol)) - (let* ((org-outline-path-cache) ; See `org-get-outline-path' docstring. - (path (thread-first (org-get-outline-path t t) - (org-format-outline-path window-width nil "") - (org-split-string ""))) - (path (if org-ql-completing-read-reverse-paths - (string-join (nreverse path) "\\") - (string-join path "/")))) - (puthash path (point-marker) table) - path)) + ;; FIXME: We want the fontified heading, and `org-heading-components' returns it + ;; without properties, so we have to use `org-get-heading', which added additional + ;; optional arguments in a certain Org version, so in those versions, it will + ;; return priority cookies and comment strings. + (let ((heading (org-get-heading t t))) + (when (gethash heading table) + ;; Disambiguate heading (even adding the path isn't enough, because that could + ;; also be duplicated). + (if-let ((suffix (gethash heading disambiguations))) + (setf heading (format "%s <%s>" heading (cl-incf suffix))) + (setf heading (format "%s <%s>" heading (puthash heading 2 disambiguations))))) + (puthash heading (point-marker) table))) + (path (marker) + (org-with-point-at marker + (let* ((path (thread-first (org-get-outline-path nil t) + (org-format-outline-path window-width nil "") + (org-split-string ""))) + (formatted-path (if org-ql-completing-read-reverse-paths + (concat "\\" (string-join (reverse path) "\\")) + (concat "/" (string-join path "/"))))) + formatted-path))) + (todo + (marker) (if-let (it (org-entry-get marker "TODO")) + (concat (propertize it 'face (org-get-todo-face it)) " ") + "")) (affix (completions) + ;; (debug-message "AFFIX:%S" completions) (cl-loop for completion in completions for marker = (gethash completion table) - for todo-state = (if-let (it (org-entry-get marker "TODO")) - (concat (propertize it - 'face (org-get-todo-face it)) - " ") - "") - for snippet = (if-let (it (snippet marker)) - (propertize (concat " " it) - 'face 'org-ql-completing-read-snippet) - "") - collect (list completion todo-state snippet))) + for prefix = (todo marker) + for suffix = (concat (path marker) " " (snippet marker)) + collect (list completion prefix suffix))) (annotate (candidate) + ;; (debug-message "ANNOTATE:%S" candidate) (while-no-input - ;; Using `while-no-input' here doesn't make it as - ;; responsive as, e.g. Helm while typing, but it seems to - ;; help a little when using the org-rifle-style snippets. + ;; Using `while-no-input' here doesn't make it as responsive as, + ;; e.g. Helm while typing, but it seems to help a little when using the + ;; org-rifle-style snippets. (or (snippet (gethash candidate table)) ""))) - (snippet (marker) - (org-with-point-at marker - (or (funcall org-ql-completing-read-snippet-function snippet-regexp) - (org-ql-completing-read--snippet-simple)))) + (snippet + (marker) (when-let + ((snippet + (org-with-point-at marker + (or (funcall org-ql-completing-read-snippet-function snippet-regexp) + (org-ql-completing-read--snippet-simple))))) + (propertize (concat " " snippet) + 'face 'org-ql-completing-read-snippet))) (group (candidate transform) (pcase transform (`nil (buffer-name (marker-buffer (gethash candidate table)))) (_ candidate))) - (try (string _table _pred point &optional _metadata) + (try (string _collection _pred point &optional _metadata) + ;; (debug-message "TRY: STRING:%S" string) (cons string point)) (all (string table pred _point) + ;; (debug-message "all: STRING:%S" string) + ;; (debug-message "all-completions RETURNS: %S" (all-completions string table pred)) (all-completions string table pred)) - (collection (str _pred flag) + (collection (input _pred flag) (when query-prefix - (setf str (concat query-prefix str))) + (setf input (concat query-prefix input))) (pcase flag ('metadata (list 'metadata (cons 'group-function #'group) (cons 'affixation-function #'affix) (cons 'annotation-function #'annotate))) - (`t (unless (string-empty-p str) - (when query-filter - (setf str (funcall query-filter str))) - (pcase org-ql-completing-read-snippet-function - ('org-ql-completing-read--snippet-regexp - (setf query-tokens - ;; Remove any tokens that specify predicates or are too short. - (--select (not (or (string-match-p (rx bos (1+ (not (any ":"))) ":") it) - (< (length it) org-ql-completing-read-snippet-minimum-token-length))) - (split-string str nil t (rx space))) - snippet-regexp - (when query-tokens - ;; Limiting each context word to 15 characters - ;; prevents excessively long, non-word strings - ;; from ending up in snippets, which can - ;; adversely affect performance. - (rx-to-string `(seq (optional (repeat 1 3 (repeat 1 15 (not space)) (0+ space))) - bow (or ,@query-tokens) (0+ (not space)) - (optional (repeat 1 3 (0+ space) (repeat 1 15 (not space)))))))))) - (org-ql-select buffers-files (org-ql--query-string-to-sexp str) - :action #'action)))))) - ;; NOTE: It seems that the `completing-read' machinery can call, - ;; abort, and re-call the collection function while the user is - ;; typing, which can interrupt the machinery Org uses to prepare - ;; an Org buffer when an Org file is loaded. This results in, - ;; e.g. the buffer being left in fundamental-mode, unprepared to - ;; be used as an Org buffer, which breaks many things and is - ;; very confusing for the user. Ideally, of course, we would - ;; solve this in `org-ql-select', and we already attempt to, but - ;; that function is called by the `completing-read' machinery, - ;; which interrupts it, so we must work around this problem by - ;; ensuring all of the BUFFERS-FILES are loaded and initialized - ;; before calling `completing-read'. + (`t + ;; (debug-message "COLLECTION:t INPUT:%S KEYS:%S" + ;; input (hash-table-keys table)) + ;; It's not ideal to call `run-query' unconditionally here, but due to + ;; the complexity of the "Programmed Completion" API, it's basically + ;; necessary, and org-ql's caching should make it nearly free. + (run-query input) + (hash-table-keys table)) + ('lambda + ;; (debug-message "COLLECTION:lambda INPUT:%S KEYS:%S" + ;; input (hash-table-keys table)) + (if (not (hash-table-empty-p table)) + (when (gethash input table) + t) + (run-query input) + (when (gethash input table) + ;; (debug-message "COLLECTION:lambda INPUT:%S FOUND" input) + t))) + (`nil + ;; (debug-message "COLLECTION:nil INPUT:%S" input) + (if (not (hash-table-empty-p table)) + (when (gethash input table) + t) + (run-query input) + ;; (debug-message "COLLECTION:nil INPUT:%S KEYS:%S" + ;; input (hash-table-keys table)) + (cond ((hash-table-empty-p table) + nil) + ((gethash input table) + t) + (t + ;; FIXME: "it should return the longest common prefix + ;; substring of all matches otherwise"...but there's no + ;; function to compute that? At least returning an empty + ;; string doesn't seem to break anything. + input)))) + (`(boundaries . ,suffix) + ;; (debug-message "COLLECTION:boundaries INPUT:%S SUFFIX:%S KEYS:%S" + ;; input suffix (hash-table-keys table)) + ;; FIXME: This is unlikely to be correct, but I'm not even sure if it + ;; can be correct in this case since the input (e.g. "todo: foo") + ;; usually won't match a completion candidate directly. + `(boundaries 0 . ,(length suffix))))) + (run-query (input) + ;; (debug-message "RUN-QUERY:%S" input) + (unless (or (string-empty-p input) + (equal last-input input)) + ;; (debug-message "RUN-QUERY:%S RUNNING" input) + (setf last-input input) + ;; Clear hash table each time the user changes the input. + (clrhash table) + (clrhash disambiguations) + (when query-filter + (setf input (funcall query-filter input))) + (pcase org-ql-completing-read-snippet-function + ('org-ql-completing-read--snippet-regexp + (setf query-tokens + ;; Remove any tokens that specify predicates or are too short. + (--select (not (or (string-match-p (rx bos (1+ (not (any ":"))) ":") it) + (< (length it) org-ql-completing-read-snippet-minimum-token-length))) + (split-string input nil t (rx space))) + snippet-regexp + (when query-tokens + ;; Limiting each context word to 15 characters prevents + ;; excessively long, non-word strings from ending up in + ;; snippets, which can adversely affect performance. + (rx-to-string `(seq (optional (repeat 1 3 (repeat 1 15 (not space)) (0+ space))) + bow (or ,@query-tokens) (0+ (not space)) + (optional (repeat 1 3 (0+ space) (repeat 1 15 (not space)))))))))) + (org-ql-select buffers-files (org-ql--query-string-to-sexp input) + :action #'action)))) + ;; NOTE: It seems that the `completing-read' machinery can call, abort, and re-call the + ;; collection function while the user is typing, which can interrupt the machinery Org uses to + ;; prepare an Org buffer when an Org file is loaded. This results in, e.g. the buffer being + ;; left in fundamental-mode, unprepared to be used as an Org buffer, which breaks many things + ;; and is very confusing for the user. Ideally, of course, we would solve this in + ;; `org-ql-select', and we already attempt to, but that function is called by the + ;; `completing-read' machinery, which interrupts it, so we must work around this problem by + ;; ensuring all of the BUFFERS-FILES are loaded and initialized before calling + ;; `completing-read'. (unless (listp buffers-files) ;; Since we map across this argument, we ensure it's a list. (setf buffers-files (list buffers-files))) (mapc #'org-ql--ensure-buffer buffers-files) (let* ((completion-styles '(org-ql-completing-read)) (completion-styles-alist (list (list 'org-ql-completing-read #'try #'all "Org QL Find"))) - (selected (completing-read prompt #'collection nil))) - (gethash selected table))))) + (selected (completing-read prompt #'collection nil t))) + ;; (debug-message "SELECTED:%S KEYS:%S" selected (hash-table-keys table)) + (or (gethash selected table) + ;; If there are completions in the table, but none of them exactly match the user input + ;; (e.g. a heading "foo" that matches a query "todo:"), `completing-read' will not + ;; select it automatically, so we return it ourselves. But note that this is not + ;; necessarily correct. For example, if the user types "todo:" and gets a list of + ;; completions ("foo" "bar"), and then changes the input to "ba" and presses RET + ;; immediately (without getting a new list of completions), the table will include "foo" + ;; and "bar", and we will return "foo"'s value rather than the first match for the query + ;; "ba", because `completing-read' will not cause the COLLECTION function to run a new + ;; query for the new input. + (car (hash-table-values table)) + (user-error "No results for input")))))) (defun org-ql-completing-read--snippet-simple (&optional _regexp) "Return a snippet of the current entry. diff --git a/org-ql.info b/org-ql.info index 741030a..7998193 100644 --- a/org-ql.info +++ b/org-ql.info @@ -1025,7 +1025,11 @@ File: README.info, Node: 071-pre, Next: 07, Up: Changelog 5.1 0.7.1-pre ============= -Nothing new yet. +*Fixes* + • Function ‘org-ql-completing-read’ is more compatible with default + Emacs completion. (See #338 + (https://github.com/alphapapa/org-ql/issues/338). Thanks to + arozbiz (https://github.com/arozbiz) for reporting.)  File: README.info, Node: 07, Next: 063, Prev: 071-pre, Up: Changelog @@ -1748,36 +1752,36 @@ Node: Links37270 Node: Tips37957 Node: Changelog38281 Node: 071-pre39079 -Node: 0739190 -Node: 06342118 -Node: 06242649 -Node: 06142954 -Node: 0643522 -Node: 05246576 -Node: 05146876 -Node: 0547299 -Node: 04948828 -Node: 04849110 -Node: 04749459 -Node: 04649868 -Node: 04550276 -Node: 04450637 -Node: 04350996 -Node: 04251199 -Node: 04151360 -Node: 0451607 -Node: 03255708 -Node: 03156111 -Node: 0356308 -Node: 02359608 -Node: 02259842 -Node: 02160122 -Node: 0260327 -Node: 0164405 -Node: Notes64506 -Node: Comparison with Org Agenda searches64668 -Node: org-sidebar65557 -Node: License65836 +Node: 0739416 +Node: 06342344 +Node: 06242875 +Node: 06143180 +Node: 0643748 +Node: 05246802 +Node: 05147102 +Node: 0547525 +Node: 04949054 +Node: 04849336 +Node: 04749685 +Node: 04650094 +Node: 04550502 +Node: 04450863 +Node: 04351222 +Node: 04251425 +Node: 04151586 +Node: 0451833 +Node: 03255934 +Node: 03156337 +Node: 0356534 +Node: 02359834 +Node: 02260068 +Node: 02160348 +Node: 0260553 +Node: 0164631 +Node: Notes64732 +Node: Comparison with Org Agenda searches64894 +Node: org-sidebar65783 +Node: License66062  End Tag Table