forked from alphapapa/org-ql
-
Notifications
You must be signed in to change notification settings - Fork 0
/
org-ql.el
367 lines (328 loc) · 16.6 KB
/
org-ql.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
;; -*- lexical-binding: t; -*-
;;; Code:
;;;; Requirements
(require 'cl-lib)
(require 'org)
(require 'seq)
(require 'dash)
;;;; Variables
(defvar org-ql--today nil)
;;;; Macros
(cl-defmacro org-ql (buffers-or-files pred-body &key (action-fn '#'identity) sort narrow)
"Find entries in BUFFERS-OR-FILES that match PRED-BODY, and return the results of running ACTION-FN on each matching entry.
ACTION-FN should take a single argument, which will be the result
of calling `org-element-headline-parser' at each matching entry.
SORT is a user defined sorting function, or an unquoted list of
one or more sorting methods, including: `date', `deadline',
`scheduled', and `priority'.
If NARROW is non-nil, query will run without widening the
buffer (the default is to widen and search the entire buffer)."
(declare (indent defun))
`(org-ql--query ,buffers-or-files
(byte-compile (lambda ()
(cl-symbol-macrolet ((= #'=)
(< #'<)
(> #'>)
(<= #'<=)
(>= #'>=))
,pred-body)))
:action-fn ,action-fn
:narrow ,narrow
:sort ,(pcase sort
(`(function ,_) sort)
(_ (list 'quote sort)))))
(defmacro org-ql--fmap (fns &rest body)
(declare (indent defun) (debug (listp body)))
`(cl-letf ,(cl-loop for (fn target) in fns
collect `((symbol-function ',fn)
(symbol-function ,target)))
,@body))
;;;; Functions
(cl-defun org-ql--query (buffers-or-files pred &key (action-fn #'identity) narrow sort)
"FIXME: Add docstring."
;; MAYBE: Set :narrow t for buffers and nil for files.
(declare (indent defun))
(let* ((buffers-or-files (cl-typecase buffers-or-files
(null (list (current-buffer)))
(buffer (list buffers-or-files))
(list buffers-or-files)
(string (list buffers-or-files))))
;; TODO: Figure out how to use or reimplement the org-scanner-tags feature.
;; (org-use-tag-inheritance t)
;; (org-trust-scanner-tags t)
(org-ql--today (org-today))
(items (-flatten-n 1 (--map (with-current-buffer (cl-typecase it
(buffer it)
(string (or (find-buffer-visiting it)
(find-file-noselect it)
(user-error "Can't open file: %s" it))))
(mapcar action-fn
(org-ql--filter-buffer :pred pred :narrow narrow)))
buffers-or-files))))
(cl-typecase sort
(list (org-ql--sort-by items sort))
(function (funcall sort items))
(null items)
(t (user-error "SORT must be a function or a list of methods (see documentation)")))))
(defun org-ql--sanity-check-form (form)
"Signal an error if any of the forms in BODY do not have their preconditions met.
Or, when possible, fix the problem."
(cl-flet ((check (symbol)
(cl-case symbol
('done (unless org-done-keywords
;; NOTE: This check needs to be done from within the Org buffer being checked.
(error "Variable `org-done-keywords' is nil. Are you running this from an Org buffer?")))
('habit (unless (featurep 'org-habit)
(require 'org-habit))))))
(cl-loop for elem in form
if (consp elem)
do (progn
(check (car elem))
(org-ql--sanity-check-form (cdr elem)))
else do (check elem))))
(cl-defun org-ql--filter-buffer (&key pred narrow)
"Return positions of matching headings in current buffer.
Headings should return non-nil for any ANY-PREDS and nil for all
NONE-PREDS. If NARROW is non-nil, buffer will not be widened
first."
;; Cache `org-today' so we don't have to run it repeatedly.
(let (today)
(cl-letf ((today org-ql--today))
(org-ql--fmap ((category #'org-ql--category-p)
(date #'org-ql--date-plain-p)
(deadline #'org-ql--deadline-p)
(scheduled #'org-ql--scheduled-p)
(closed #'org-ql--closed-p)
(habit #'org-ql--habit-p)
(priority #'org-ql--priority-p)
(todo #'org-ql--todo-p)
(done #'org-ql--done-p)
(tags #'org-ql--tags-p)
(property #'org-ql--property-p)
(regexp #'org-ql--regexp-p)
(org-back-to-heading #'outline-back-to-heading))
(save-excursion
(save-restriction
(unless narrow
(widen))
(goto-char (point-min))
(when (org-before-first-heading-p)
(outline-next-heading))
(cl-loop when (funcall pred)
collect (org-element-headline-parser (line-end-position))
while (outline-next-heading))))))))
;;;;; Predicates
(defun org-ql--category-p (&rest categories)
"Return non-nil if current heading is in one or more of CATEGORIES."
(when-let ((category (org-get-category (point))))
(cl-typecase categories
(null t)
(otherwise (member category categories)))))
(defun org-ql--todo-p (&rest keywords)
"Return non-nil if current heading is a TODO item.
With KEYWORDS, return non-nil if its keyword is one of KEYWORDS."
(when-let ((state (org-get-todo-state)))
(cl-typecase keywords
(null t)
(list (member state keywords))
(symbol (member state (symbol-value keywords)))
(otherwise (user-error "Invalid todo keywords: %s" keywords)))))
(defsubst org-ql--done-p ()
(or (apply #'org-ql--todo-p org-done-keywords)))
(defun org-ql--tags-p (&rest tags)
"Return non-nil if current heading has one or more of TAGS."
;; TODO: Try to use `org-make-tags-matcher' to improve performance. It would be nice to not have
;; to run `org-get-tags-at' for every heading, especially with inheritance.
(when-let ((tags-at (org-get-tags-at (point) (not org-use-tag-inheritance))))
(cl-typecase tags
(null t)
(otherwise (seq-intersection tags tags-at)))))
(defun org-ql--date-p (type &optional comparator target-date)
"Return non-nil if current heading has a date property of TYPE.
TYPE should be a keyword symbol, like :scheduled or :deadline.
With COMPARATOR and TARGET-DATE, return non-nil if entry's
scheduled date compares with TARGET-DATE according to COMPARATOR.
TARGET-DATE may be a string like \"2017-08-05\", or an integer
like one returned by `date-to-day'."
(when-let ((timestamp (pcase type
;; FIXME: Add :date selector, since I put it
;; in the examples but forgot to actually
;; make it.
(:deadline (org-entry-get (point) "DEADLINE"))
(:scheduled (org-entry-get (point) "SCHEDULED"))
(:closed (org-entry-get (point) "CLOSED"))))
(date-element (with-temp-buffer
;; FIXME: Hack: since we're using
;; (org-element-property :type date-element)
;; below, we need this date parsed into an
;; org-element element
(insert timestamp)
(goto-char 0)
(org-element-timestamp-parser))))
(pcase comparator
;; Not comparing, just checking if it has one
('nil t)
;; Compare dates
((pred functionp)
(let ((target-day-number (cl-typecase target-date
(null (+ (org-get-wdays timestamp) (org-today)))
;; Append time to target-date
;; because `date-to-day' requires it
(string (date-to-day (concat target-date " 00:00")))
(integer target-date))))
(pcase (org-element-property :type date-element)
((or 'active 'inactive)
(funcall comparator
(org-time-string-to-absolute
(org-element-timestamp-interpreter date-element 'ignore))
target-day-number))
(error "Unknown date-element type: %s" (org-element-property :type date-element)))))
(otherwise (user-error "COMPARATOR (%s) must be a function, and DATE (%s) must be a string or day-number integer"
comparator target-date)))))
(defsubst org-ql--date-plain-p (&optional comparator target-date)
(org-ql--date-p :date comparator target-date))
(defsubst org-ql--deadline-p (&optional comparator target-date)
;; FIXME: This is slightly confusing. Using plain (deadline) does, and should, select entries
;; that have any deadline. But the common case of wanting to select entries whose deadline is
;; within the warning days (either the global setting or that entry's setting) requires the user
;; to specify the <= comparator, which is unintuitive. Maybe it would be better to use that
;; comparator by default, and use an 'any comparator to select entries with any deadline. Of
;; course, that would make the deadline selector different from the scheduled, closed, and date
;; selectors, which would also be unintuitive.
(org-ql--date-p :deadline comparator target-date))
(defsubst org-ql--scheduled-p (&optional comparator target-date)
(org-ql--date-p :scheduled comparator target-date))
(defsubst org-ql--closed-p (&optional comparator target-date)
(org-ql--date-p :closed comparator target-date))
(defun org-ql--priority-p (&optional comparator-or-priority priority)
"Return non-nil if current heading has a certain priority.
COMPARATOR-OR-PRIORITY should be either a comparator function,
like `<=', or a priority string, like \"A\" (in which case (\` =)
'will be the comparator). If COMPARATOR-OR-PRIORITY is a
comparator, PRIORITY should be a priority string."
(let* (comparator)
(cond ((null priority)
;; No comparator given: compare only given priority with =
(setq priority comparator-or-priority
comparator '=))
(t
;; Both comparator and priority given
(setq comparator comparator-or-priority)))
(setq comparator (cl-case comparator
;; Invert comparator because higher priority means lower number
(< '>)
(> '<)
(<= '>=)
(>= '<=)
(= '=)
(otherwise (user-error "Invalid comparator: %s" comparator))))
(setq priority (* 1000 (- org-lowest-priority (string-to-char priority))))
(when-let ((item-priority (save-excursion
(save-match-data
;; FIXME: Is the save-match-data above necessary?
(when (and (looking-at org-heading-regexp)
(save-match-data
(string-match org-priority-regexp (match-string 0))))
;; TODO: Items with no priority
;; should not be the same as B
;; priority. That's not very
;; useful IMO. Better to do it
;; like in org-super-agenda.
(org-get-priority (match-string 0)))))))
(funcall comparator priority item-priority))))
(defun org-ql--habit-p ()
(org-is-habit-p))
(defun org-ql--regexp-p (regexp)
"Return non-nil if current entry matches REGEXP."
(let ((end (or (save-excursion
(outline-next-heading))
(point-max))))
(save-excursion
(goto-char (line-beginning-position))
(re-search-forward regexp end t))))
(defun org-ql--property-p (property &optional value)
"Return non-nil if current entry has PROPERTY, and optionally VALUE."
(pcase property
('nil (user-error "Property matcher requires a PROPERTY argument."))
(_ (pcase value
('nil
;; Check that PROPERTY exists
(org-entry-get (point) property))
(_
;; Check that PROPERTY has VALUE
(string-equal value (org-entry-get (point) property 'selective)))))))
;;;;; Sorting
;; FIXME: These appear to work properly, but it would be good to have tests for them.
(defun org-ql--sort-by (items predicates)
"Return ITEMS sorted by PREDICATES.
PREDICATES is a list of one or more sorting methods, including:
`deadline', `scheduled', and `priority'."
;; FIXME: Test `date' type.
;; MAYBE: Use macrolet instead of flet.
(cl-flet* ((sorter (symbol)
(pcase symbol
((or 'deadline 'scheduled)
(apply-partially #'org-ql--date-type< (intern (concat ":" (symbol-name symbol)))))
('date #'org-ql--date<)
('priority #'org-ql--priority<)
;; NOTE: 'todo is handled below
;; FIXME: Add more?
(_ (user-error "Invalid sorting predicate: %s" symbol))))
(todo-keyword-pos (keyword)
;; MAYBE: Would it be faster to precompute these and do an alist lookup?
(cl-position keyword org-todo-keywords-1 :test #'string=))
(sort-by-todo-keyword (items)
(let* ((grouped-items (--group-by (when-let (keyword (org-element-property :todo-keyword it))
(substring-no-properties keyword))
items))
(sorted-groups (cl-sort grouped-items #'<
:key (lambda (keyword)
(or (cl-position (car keyword) org-todo-keywords-1 :test #'string=)
;; Put at end of list if not found
(1+ (length org-todo-keywords-1)))))))
(-flatten-n 1 (-map #'cdr sorted-groups)))))
(cl-loop for pred in (nreverse predicates)
do (setq items (if (eq pred 'todo)
(sort-by-todo-keyword items)
(-sort (sorter pred) items)))
finally return items)))
(defun org-ql--date-type< (type a b)
"Return non-nil if A's date of TYPE is earlier than B's.
A and B are Org headline elements. TYPE should be a symbol like
`:deadline' or `:scheduled'"
(org-ql--org-timestamp-element< (org-element-property type a)
(org-element-property type b)))
(defun org-ql--date< (a b)
"Return non-nil if A's deadline or scheduled element property is earlier than B's.
Deadline is considered before scheduled."
(cl-macrolet ((ts (item)
`(or (org-element-property :deadline ,item)
(org-element-property :scheduled ,item))))
(org-ql--org-timestamp-element< (ts a) (ts b))))
(defun org-ql--org-timestamp-element< (a b)
"Return non-nil if A's date element is earlier than B's.
A and B are Org timestamp elements."
(cl-macrolet ((ts (ts)
`(when ,ts
(org-timestamp-format ,ts "%s"))))
(let* ((a-ts (ts a))
(b-ts (ts b)))
(cond ((and a-ts b-ts)
(string< a-ts b-ts))
(a-ts t)
(b-ts nil)))))
(defun org-ql--priority< (a b)
"Return non-nil if A's priority is higher than B's.
A and B are Org headline elements."
(cl-flet ((priority (item)
(org-element-property :priority item)))
;; NOTE: Priorities are numbers in Org elements. This might differ from the priority selector logic.
(let ((a-priority (priority a))
(b-priority (priority b)))
(cond ((and a-priority b-priority)
(< a-priority b-priority))
(a-priority t)
(b-priority nil)))))
;;;; Footer
(provide 'org-ql)
;;; org-ql.el ends here