-
Notifications
You must be signed in to change notification settings - Fork 110
/
org-ql-completing-read.el
402 lines (363 loc) · 21.3 KB
/
org-ql-completing-read.el
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
;;; org-ql-completing-read.el --- Completing read of Org entries using org-ql -*- lexical-binding: t; -*-
;; Copyright (C) 2022-2023 Adam Porter
;; Author: Adam Porter <adam@alphapapa.net>
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; This library provides completing-read of Org entries using `org-ql'
;; search.
;;; Code:
(require 'org-ql)
(declare-function org-ql-search "org-ql-search")
(declare-function org-ql--normalize-query "org-ql" t t)
;;;; Variables
(defvar-keymap org-ql-completing-read-map
:doc "Active during `org-ql-completing-read' sessions."
"C-c C-e" #'org-ql-completing-read-export)
;; `embark-collect' doesn't work for `org-ql-completing-read', so remap
;; it to `embark-export' (which `keymap-set', et al doesn't allow).
(define-key org-ql-completing-read-map [remap embark-collect] 'embark-export)
;;;; Customization
(defgroup org-ql-completing-read nil
"Completing-read of Org entries using `org-ql' search."
:group 'org-ql)
(defcustom org-ql-completing-read-reverse-paths t
"Whether to reverse Org outline paths in `org-ql-completing-read' results."
:type 'boolean)
(defcustom org-ql-completing-read-snippet-function #'org-ql-completing-read--snippet-simple
;; TODO(v0.9): Performance of completion annotations seems to be
;; much improved now (whether due to changes in Emacs, Vertico, or
;; both, I don't know). It may be reasonable to make the context
;; snippet the default now.
"Function used to annotate results in `org-ql-completing-read'.
Function is called at entry beginning. (When set to
`org-ql-completing-read--snippet-regexp', it is called with a
regexp matching plain query tokens.)"
:type '(choice (function-item :tag "Show context around search terms" org-ql-completing-read--snippet-regexp)
(function-item :tag "Show first N characters" org-ql-completing-read--snippet-simple)
(function :tag "Custom function")))
(defcustom org-ql-completing-read-snippet-length 51
"Size of snippets of entry content to include in completion annotations.
Only used when `org-ql-completing-read-snippet-function' is set
to `org-ql-completing-read--snippet-regexp'."
:type 'integer)
(defcustom org-ql-completing-read-snippet-minimum-token-length 3
"Query tokens shorter than this many characters are ignored.
That is, they are not included when gathering entry snippets.
This avoids too-small tokens causing performance problems."
:type 'integer)
(defcustom org-ql-completing-read-snippet-prefix nil
"String prepended to snippets.
For an experience like `org-rifle', use a newline."
:type '(choice (const :tag "None (shown on same line)" nil)
(const :tag "New line (shown under heading)" "\n")
string))
(defface org-ql-completing-read-snippet '((t (:inherit font-lock-comment-face)))
"Snippets.")
(defvar org-ql-completing-read-input-regexp nil
"Current regexp for `org-ql-completing-read' input.
To be used in, e.g. annotation functions.")
;;;; Functions
(defun org-ql-completing-read-action ()
"Default action for `org-ql-completing-read'.
Returns (STRING . MARKER) cons for entry at point."
(font-lock-ensure (pos-bol) (pos-eol))
(cons (org-link-display-format (org-entry-get nil "ITEM")) (point-marker)))
(defun org-ql-completing-read-snippet (marker)
"Return snippet for entry at MARKER.
Returns value returned by function
`org-ql-completing-read-snippet-function' or
`org-ql-completing-read--snippet-simple', whichever returns a
value, or nil."
(pcase (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.
(org-with-point-at marker
(or (funcall org-ql-completing-read-snippet-function
org-ql-completing-read-input-regexp)
(org-ql-completing-read--snippet-simple))))
(`t ;; Interrupted: return nil (which can be concatted).
nil)
(else (propertize (concat " " else)
'face 'org-ql-completing-read-snippet))))
(defun org-ql-completing-read-path (marker)
"Return formatted outline path for entry at 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 " "))))
(if org-ql-completing-read-reverse-paths
(concat "\\" (string-join (reverse path) "\\"))
(concat "/" (string-join path "/"))))))
;;;;; Completing read
(defun org-ql-completing-read-export ()
"Show `org-ql-view' buffer for current `org-ql-completing-read'-based search."
(interactive)
(user-error "Not in an `org-ql-completing-read' session"))
;;;###autoload
(cl-defun org-ql-completing-read
(buffers-files &key query-prefix query-filter narrowp
(action #'org-ql-completing-read-action)
;; FIXME: Unused argument.
;; (annotate #'org-ql-completing-read-snippet)
(snippet #'org-ql-completing-read-snippet)
(path #'org-ql-completing-read-path)
(action-filter #'list)
(prompt "Find entry: "))
"Return marker at entry in BUFFERS-FILES selected with `org-ql'.
PROMPT is shown to the user.
NARROWP is passed to `org-ql-select', which see.
QUERY-PREFIX may be a string to prepend to the query entered by
the user (e.g. use \"heading:\" to only search headings, easily
creating a custom command that saves the user from having to type
it).
QUERY-FILTER may be a function through which the query the user
types is filtered before execution (e.g. it could replace spaces
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
;; <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))
last-input org-outline-path-cache query-tokens)
(cl-labels (;; (debug-message
;; (f &rest args) (apply #'message (concat "ORG-QL-COMPLETING-READ: " f) args))
(action ()
(font-lock-ensure (pos-bol) (pos-eol))
;; This function needs to handle multiple candidates per
;; call, so we loop over a list of values by default.
(pcase-dolist (`(,string . ,marker) (funcall action-filter (funcall action)))
(when string
(if (string-empty-p string)
;; A heading's string can be empty, but we can't use one because it
;; wouldn't be useful to the user; and if one is found, it's very
;; likely to indicate an unnoticed mistake or corruption in the
;; file: so display a warning and don't record it as a candidate.
(display-warning 'org-ql-completing-read (format-message "Empty heading at %S" marker))
(when (gethash string table)
;; Disambiguate string (even adding the path isn't enough, because that could
;; also be duplicated).
(if-let ((suffix (gethash string disambiguations)))
(setf string (format "%s <%s>" string (cl-incf suffix)))
(setf string (format "%s <%s>" string (puthash string 2 disambiguations)))))
(puthash (propertize string 'org-marker marker) 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 = (get-text-property 0 'org-marker completion)
for prefix = (todo marker)
for suffix = (concat (funcall path marker) " " (funcall 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.
(or (funcall snippet (get-text-property 0 'org-marker candidate)) "")))
(group (candidate transform)
(pcase transform
(`nil (buffer-name (marker-buffer (get-text-property 0 'org-marker candidate))))
(_ candidate)))
(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 (input _pred flag)
(pcase flag
('metadata (list 'metadata
(cons 'category 'org-heading)
(cons 'group-function #'group)
(cons 'affixation-function #'affix)
(cons 'annotation-function #'annotate)
(cons 'display-sort-function
(lambda (strings)
(let ((quoted-tokens (mapcar #'regexp-quote query-tokens)))
(sort strings
(lambda (a b)
(cl-labels ((matches
(s) (cl-loop for token in quoted-tokens
count (string-match-p token s))))
(> (matches a) (matches b))))))))))
(`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)
(when query-prefix
(setf input (concat query-prefix 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)))
(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 blank)))
org-ql-completing-read-input-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)
:narrow narrowp
:action #'action))))
(unless (listp buffers-files)
;; Since we map across this argument, we ensure it's a list.
(setf buffers-files (list buffers-files)))
;; 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'.
(mapc #'org-ql--ensure-buffer buffers-files)
(let* ((completion-styles '(org-ql-completing-read))
(completion-styles-alist (cons (list 'org-ql-completing-read #'try #'all "Org QL Find")
completion-styles-alist))
(selected
(minibuffer-with-setup-hook
(lambda ()
(use-local-map (make-composed-keymap org-ql-completing-read-map (current-local-map))))
(cl-letf* (((symbol-function 'org-ql-completing-read-export)
(lambda ()
(interactive)
(run-at-time 0 nil
#'org-ql-search
buffers-files
(minibuffer-contents-no-properties))
(if (fboundp 'minibuffer-quit-recursive-edit)
(minibuffer-quit-recursive-edit)
(abort-recursive-edit))))
((symbol-function 'embark-export)
(symbol-function 'org-ql-completing-read-export)))
(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 _input-regexp)
"Return a snippet of the current entry.
Returns up to `org-ql-completing-read-snippet-length' characters."
(save-excursion
(org-end-of-meta-data t)
(unless (org-at-heading-p)
(let ((end (min (+ (point) org-ql-completing-read-snippet-length)
(org-entry-end-position))))
(concat org-ql-completing-read-snippet-prefix
(truncate-string-to-width
(replace-regexp-in-string "\n" " " (buffer-substring (point) end)
t t)
50 nil nil t))))))
(defun org-ql-completing-read--snippet-regexp (&optional input-regexp)
"Return a snippet of the current entry's matches for INPUT-REGEXP."
;; REGEXP may be nil if there are no qualifying tokens in the query.
(when input-regexp
(save-excursion
(org-end-of-meta-data t)
(unless (org-at-heading-p)
(let* ((end (org-entry-end-position))
(snippets (cl-loop while (re-search-forward input-regexp end t)
concat (match-string 0) concat "…"
do (goto-char (match-end 0)))))
(unless (string-empty-p snippets)
(concat org-ql-completing-read-snippet-prefix
(replace-regexp-in-string (rx (1+ "\n")) " " snippets t t))))))))
;;;; Footer
(provide 'org-ql-completing-read)
;;; org-ql-completing-read.el ends here