Skip to content

Commit

Permalink
Fix: (org-ql-completing-read)
Browse files Browse the repository at this point in the history 
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.
  • Loading branch information
@alphapapa
alphapapa committed Mar 12, 2023
1 parent e08de2a commit 4c1a4b1
Show file tree
Hide file tree
Showing 3 changed files with 192 additions and 101 deletions.
3 changes: 2 additions & 1 deletion README.org
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
224 changes: 155 additions & 69 deletions org-ql-completing-read.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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
;; <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))
(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.
Expand Down
Loading

0 comments on commit 4c1a4b1

Please sign in to comment.