jiri/org-ql
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Fix: (org-ql-completing-read)

Browse source 
This seems to work better now with default Emacs completion (i.e. not
using Vertico or Helm).  It's still not perfect, but it seems to work
reasonably well and be more correct.

Fixes #338.  Thanks to @arozbiz for reporting.
This commit is contained in:
Adam Porter 2023-03-12 09:30:29 -05:00
parent e08de2a76c
commit 4c1a4b169f
3 changed files with 192 additions and 101 deletions
Download patch file Download diff file Expand all files Collapse all files

3
README.org
View file

@ -545,7 +545,8 @@ Simple links may also be written manually in either sexp or non-sexp form, like:
** 0.7.1-pre ** 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 ** 0.7

192
org-ql-completing-read.el
View file

@ -94,104 +94,190 @@ with commas to turn multiple tokens, which would normally be
treated as multiple predicates, into multiple arguments to a treated as multiple predicates, into multiple arguments to a
single predicate)." single predicate)."
(declare (indent defun)) (declare (indent defun))
;; Emacs's completion API is not always easy to understand, ;; Emacs's completion API is not always easy to understand, especially when using "programmed
;; especially when using "programmed completion." This code was ;; completion." This code was made possible by the example Clemens Radermacher shared at
;; made possible by the example Clemens Radermacher shared at
;; <https://github.com/radian-software/selectrum/issues/114#issuecomment-744041532>. ;; <https://github.com/radian-software/selectrum/issues/114#issuecomment-744041532>.
;; 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)) (let ((table (make-hash-table :test #'equal))
(disambiguations (make-hash-table :test #'equal))
(window-width (window-width)) (window-width (window-width))
query-tokens snippet-regexp) last-input org-outline-path-cache query-tokens snippet-regexp)
(cl-labels ((action (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)) () (font-lock-ensure (point-at-bol) (point-at-eol))
(let* ((org-outline-path-cache) ; See `org-get-outline-path' docstring. ;; FIXME: We want the fontified heading, and `org-heading-components' returns it
(path (thread-first (org-get-outline-path t t) ;; 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-format-outline-path window-width nil "")
(org-split-string ""))) (org-split-string "")))
(path (if org-ql-completing-read-reverse-paths (formatted-path (if org-ql-completing-read-reverse-paths
(string-join (nreverse path) "\\") (concat "\\" (string-join (reverse path) "\\"))
(string-join path "/")))) (concat "/" (string-join path "/")))))
(puthash path (point-marker) table) formatted-path)))
path)) (todo
(marker) (if-let (it (org-entry-get marker "TODO"))
(concat (propertize it 'face (org-get-todo-face it)) " ")
""))
(affix (completions) (affix (completions)
;; (debug-message "AFFIX:%S" completions)
(cl-loop for completion in completions (cl-loop for completion in completions
for marker = (gethash completion table) for marker = (gethash completion table)
for todo-state = (if-let (it (org-entry-get marker "TODO")) for prefix = (todo marker)
(concat (propertize it for suffix = (concat (path marker) " " (snippet marker))
'face (org-get-todo-face it)) collect (list completion prefix suffix)))
" ")
"")
for snippet = (if-let (it (snippet marker))
(propertize (concat " " it)
'face 'org-ql-completing-read-snippet)
"")
collect (list completion todo-state snippet)))
(annotate (candidate) (annotate (candidate)
;; (debug-message "ANNOTATE:%S" candidate)
(while-no-input (while-no-input
;; Using `while-no-input' here doesn't make it as ;; Using `while-no-input' here doesn't make it as responsive as,
;; responsive as, e.g. Helm while typing, but it seems to ;; e.g. Helm while typing, but it seems to help a little when using the
;; help a little when using the org-rifle-style snippets. ;; org-rifle-style snippets.
(or (snippet (gethash candidate table)) ""))) (or (snippet (gethash candidate table)) "")))
(snippet (marker) (snippet
(marker) (when-let
((snippet
(org-with-point-at marker (org-with-point-at marker
(or (funcall org-ql-completing-read-snippet-function snippet-regexp) (or (funcall org-ql-completing-read-snippet-function snippet-regexp)
(org-ql-completing-read--snippet-simple)))) (org-ql-completing-read--snippet-simple)))))
(propertize (concat " " snippet)
'face 'org-ql-completing-read-snippet)))
(group (candidate transform) (group (candidate transform)
(pcase transform (pcase transform
(`nil (buffer-name (marker-buffer (gethash candidate table)))) (`nil (buffer-name (marker-buffer (gethash candidate table))))
(_ candidate))) (_ candidate)))
(try (string _table _pred point &optional _metadata) (try (string _collection _pred point &optional _metadata)
;; (debug-message "TRY: STRING:%S" string)
(cons string point)) (cons string point))
(all (string table pred _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)) (all-completions string table pred))
(collection (str _pred flag) (collection (input _pred flag)
(when query-prefix (when query-prefix
(setf str (concat query-prefix str))) (setf input (concat query-prefix input)))
(pcase flag (pcase flag
('metadata (list 'metadata ('metadata (list 'metadata
(cons 'group-function #'group) (cons 'group-function #'group)
(cons 'affixation-function #'affix) (cons 'affixation-function #'affix)
(cons 'annotation-function #'annotate))) (cons 'annotation-function #'annotate)))
(`t (unless (string-empty-p str) (`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 (when query-filter
(setf str (funcall query-filter str))) (setf input (funcall query-filter input)))
(pcase org-ql-completing-read-snippet-function (pcase org-ql-completing-read-snippet-function
('org-ql-completing-read--snippet-regexp ('org-ql-completing-read--snippet-regexp
(setf query-tokens (setf query-tokens
;; Remove any tokens that specify predicates or are too short. ;; Remove any tokens that specify predicates or are too short.
(--select (not (or (string-match-p (rx bos (1+ (not (any ":"))) ":") it) (--select (not (or (string-match-p (rx bos (1+ (not (any ":"))) ":") it)
(< (length it) org-ql-completing-read-snippet-minimum-token-length))) (< (length it) org-ql-completing-read-snippet-minimum-token-length)))
(split-string str nil t (rx space))) (split-string input nil t (rx space)))
snippet-regexp snippet-regexp
(when query-tokens (when query-tokens
;; Limiting each context word to 15 characters ;; Limiting each context word to 15 characters prevents
;; prevents excessively long, non-word strings ;; excessively long, non-word strings from ending up in
;; from ending up in snippets, which can ;; snippets, which can adversely affect performance.
;; adversely affect performance.
(rx-to-string `(seq (optional (repeat 1 3 (repeat 1 15 (not space)) (0+ space))) (rx-to-string `(seq (optional (repeat 1 3 (repeat 1 15 (not space)) (0+ space)))
bow (or ,@query-tokens) (0+ (not space)) bow (or ,@query-tokens) (0+ (not space))
(optional (repeat 1 3 (0+ space) (repeat 1 15 (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) (org-ql-select buffers-files (org-ql--query-string-to-sexp input)
:action #'action)))))) :action #'action))))
;; NOTE: It seems that the `completing-read' machinery can call, ;; NOTE: It seems that the `completing-read' machinery can call, abort, and re-call the
;; abort, and re-call the collection function while the user is ;; collection function while the user is typing, which can interrupt the machinery Org uses to
;; typing, which can interrupt the machinery Org uses to prepare ;; prepare an Org buffer when an Org file is loaded. This results in, e.g. the buffer being
;; an Org buffer when an Org file is loaded. This results in, ;; left in fundamental-mode, unprepared to be used as an Org buffer, which breaks many things
;; e.g. the buffer being left in fundamental-mode, unprepared to ;; and is very confusing for the user. Ideally, of course, we would solve this in
;; be used as an Org buffer, which breaks many things and is ;; `org-ql-select', and we already attempt to, but that function is called by the
;; very confusing for the user. Ideally, of course, we would ;; `completing-read' machinery, which interrupts it, so we must work around this problem by
;; solve this in `org-ql-select', and we already attempt to, but ;; ensuring all of the BUFFERS-FILES are loaded and initialized before calling
;; that function is called by the `completing-read' machinery, ;; `completing-read'.
;; 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) (unless (listp buffers-files)
;; Since we map across this argument, we ensure it's a list. ;; Since we map across this argument, we ensure it's a list.
(setf buffers-files (list buffers-files))) (setf buffers-files (list buffers-files)))
(mapc #'org-ql--ensure-buffer buffers-files) (mapc #'org-ql--ensure-buffer buffers-files)
(let* ((completion-styles '(org-ql-completing-read)) (let* ((completion-styles '(org-ql-completing-read))
(completion-styles-alist (list (list 'org-ql-completing-read #'try #'all "Org QL Find"))) (completion-styles-alist (list (list 'org-ql-completing-read #'try #'all "Org QL Find")))
(selected (completing-read prompt #'collection nil))) (selected (completing-read prompt #'collection nil t)))
(gethash selected table))))) ;; (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) (defun org-ql-completing-read--snippet-simple (&optional _regexp)
"Return a snippet of the current entry. "Return a snippet of the current entry.

66
org-ql.info
View file

@ -1025,7 +1025,11 @@ File: README.info, Node: 071-pre, Next: 07, Up: Changelog
5.1 0.7.1-pre 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 File: README.info, Node: 07, Next: 063, Prev: 071-pre, Up: Changelog
@ -1748,36 +1752,36 @@ Node: Links37270
Node: Tips37957 Node: Tips37957
Node: Changelog38281 Node: Changelog38281
Node: 071-pre39079 Node: 071-pre39079
Node: 0739190 Node: 0739416
Node: 06342118 Node: 06342344
Node: 06242649 Node: 06242875
Node: 06142954 Node: 06143180
Node: 0643522 Node: 0643748
Node: 05246576 Node: 05246802
Node: 05146876 Node: 05147102
Node: 0547299 Node: 0547525
Node: 04948828 Node: 04949054
Node: 04849110 Node: 04849336
Node: 04749459 Node: 04749685
Node: 04649868 Node: 04650094
Node: 04550276 Node: 04550502
Node: 04450637 Node: 04450863
Node: 04350996 Node: 04351222
Node: 04251199 Node: 04251425
Node: 04151360 Node: 04151586
Node: 0451607 Node: 0451833
Node: 03255708 Node: 03255934
Node: 03156111 Node: 03156337
Node: 0356308 Node: 0356534
Node: 02359608 Node: 02359834
Node: 02259842 Node: 02260068
Node: 02160122 Node: 02160348
Node: 0260327 Node: 0260553
Node: 0164405 Node: 0164631
Node: Notes64506 Node: Notes64732
Node: Comparison with Org Agenda searches64668 Node: Comparison with Org Agenda searches64894
Node: org-sidebar65557 Node: org-sidebar65783
Node: License65836 Node: License66062
 
End Tag Table End Tag Table