forked from alphapapa/org-ql
-
Notifications
You must be signed in to change notification settings - Fork 0
/
Copy pathorg-ql-find.el
261 lines (232 loc) · 12.8 KB
/
org-ql-find.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
;;; org-ql-find.el --- Find headings with completion using org-ql -*- lexical-binding: t; -*-
;; Copyright (C) 2022 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 a way to quickly find and go to Org entries
;; selected with Emacs's built-in completions API (so it works with
;; packages that extend it, like Vertico, Marginalia, etc). It works
;; like `helm-org-ql' but does not require Helm.
;;; Code:
(require 'cl-lib)
(require 'org)
(require 'org-ql)
(require 'org-ql-search)
;;;; Customization
(defgroup org-ql-find nil
"Options for `org-ql-find'."
:group 'org-ql)
(defcustom org-ql-find-reverse-paths t
"Whether to reverse Org outline paths in `org-ql-find' results."
:type 'boolean)
(defcustom org-ql-find-goto-hook '(org-show-entry)
"Functions called when selecting an entry."
:type 'hook)
(defcustom org-ql-find-snippet-function #'org-ql-find--snippet-simple
;; TODO: I'd like to make the -regexp one the default, but with
;; default Emacs completion affixation, it can sometimes be a bit
;; slow, and I don't want that to be a user's first impression. It
;; may be possible to further optimize the -regexp one so that it
;; can be used by default. In the meantime, the -simple one seems
;; fast enough for general use.
"Function used to annotate results in `org-ql-find'.
Function is called at entry beginning. (When set to
`org-ql-find--snippet-regexp', it is called with a regexp
matching plain query tokens.)"
:type '(choice (function-item :tag "Show context around search terms" org-ql-find--snippet-regexp)
(function-item :tag "Show first N characters" org-ql-find--snippet-simple)
(function :tag "Custom function")))
(defcustom org-ql-find-snippet-length 51
"Size of snippets of entry content to include in `org-ql-find' annotations.
Only used when `org-ql-find-snippet-function' is set to
`org-ql-find--snippet-regexp'."
:type 'integer)
(defcustom org-ql-find-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-find-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-find-snippet '((t (:inherit font-lock-comment-face)))
"Snippets.")
;;;; Functions
;;;###autoload
(cl-defun org-ql-find (buffers-files &key query-prefix query-filter
(prompt "Find entry: "))
"Go to an Org entry in BUFFERS-FILES selected by searching entries with `org-ql'.
Interactively, with universal prefix, select multiple buffers to
search with completion.
QUERY-PREFIX may be a string to prepend to the query (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)."
(interactive
(list (if current-prefix-arg
(mapcar #'get-buffer
(completing-read-multiple
"Buffers: "
(mapcar #'buffer-name
(cl-remove-if-not (lambda (buffer)
(eq 'org-mode (buffer-local-value 'major-mode buffer)))
(buffer-list))) nil t))
(progn
(unless (eq major-mode 'org-mode)
(user-error "This is not an Org buffer: %S" (current-buffer)))
(current-buffer)))))
;; 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>.
(let ((table (make-hash-table :test #'equal))
(window-width (window-width))
query-tokens snippet-regexp)
(cl-labels ((action
() (font-lock-ensure (point-at-bol) (point-at-eol))
(let* ((path (thread-first (org-get-outline-path t t)
(org-format-outline-path window-width nil " ")
(org-split-string " ")))
(path (if org-ql-find-reverse-paths
(string-join (nreverse path) "\\")
(string-join path "/"))))
(puthash path (point-marker) table)
path))
(affix (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-find-snippet)
"")
collect (list completion todo-state snippet)))
(annotate (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 (snippet (gethash candidate table)) "")))
(snippet (marker)
(org-with-point-at marker
(or (funcall org-ql-find-snippet-function snippet-regexp)
(org-ql-find--snippet-simple))))
(group (candidate transform)
(pcase transform
(`nil (buffer-name (marker-buffer (gethash candidate table))))
(_ candidate)))
(try (string _table _pred point &optional _metadata)
(cons string point))
(all (string table pred _point)
(all-completions string table pred))
(collection (str _pred flag)
(when query-prefix
(setf str (concat query-prefix str)))
(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-find-snippet-function
('org-ql-find--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-find-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'.
(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-find))
(completion-styles-alist (list (list 'org-ql-find #'try #'all "Org QL Find")))
(selected (completing-read prompt #'collection nil))
(marker (gethash selected table)))
(with-current-buffer (marker-buffer marker)
(goto-char marker)
(display-buffer (current-buffer))
(select-window (get-buffer-window (current-buffer)))
(run-hook-with-args 'org-ql-find-goto-hook))))))
;;;###autoload
(defun org-ql-find-in-agenda ()
"Call `org-ql-find' on `org-agenda-files'."
(interactive)
(org-ql-find (org-agenda-files)))
;;;###autoload
(defun org-ql-find-in-org-directory ()
"Call `org-ql-find' on files in `org-directory'."
(interactive)
(org-ql-find (org-ql-search-directories-files)))
(defun org-ql-find--snippet-simple (&optional _regexp)
"Return a snippet of the current entry.
Returns up to `org-ql-find-snippet-length' characters."
(org-end-of-meta-data t)
(unless (org-at-heading-p)
(let ((end (min (+ (point) org-ql-find-snippet-length)
(org-entry-end-position))))
(concat org-ql-find-snippet-prefix
(truncate-string-to-width
(replace-regexp-in-string "\n" " " (buffer-substring (point) end)
t t)
50 nil nil t)))))
(defun org-ql-find--snippet-regexp (regexp)
"Return a snippet of the current entry's matches for REGEXP."
;; REGEXP may be nil if there are no qualifying tokens in the query.
(when regexp
(org-end-of-meta-data t)
(unless (org-at-heading-p)
(let* ((end (org-entry-end-position))
(snippets (cl-loop while (re-search-forward regexp end t)
concat (match-string 0) concat "…"
do (goto-char (match-end 0)))))
(unless (string-empty-p snippets)
(concat org-ql-find-snippet-prefix
(replace-regexp-in-string (rx (1+ "\n")) " " snippets t t)))))))
(provide 'org-ql-find)
;;; org-ql-find.el ends here