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

Add: (org-ql) Optionally don't widen buffers

Browse source
This commit is contained in:
Adam Porter 2018-05-23 07:49:44 -05:00
parent d722e4db72
commit a3cb114f71
1 changed files with 23 additions and 14 deletions
Download patch file Download diff file Expand all files Collapse all files

27
org-ql.el
View file

@ -14,7 +14,7 @@
;;;; Macros ;;;; Macros
(cl-defmacro org-ql (files pred-body &key (action-fn (lambda (element) element)) sort) (cl-defmacro org-ql (files pred-body &key (action-fn (lambda (element) element)) sort narrow)
"Find entries in FILES that match PRED-BODY, and return the results of running ACTION-FN on each matching entry. "Find entries in 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 ACTION-FN should take a single argument, which will be the result
@ -22,7 +22,10 @@ of calling `org-element-headline-parser' at each matching entry.
SORT is a user defined sorting function, or an unquoted list of SORT is a user defined sorting function, or an unquoted list of
one or more sorting methods, including: `date', `deadline', one or more sorting methods, including: `date', `deadline',
`scheduled', and `priority'." `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)) (declare (indent defun))
`(let ((items (org-ql--query ,files `(let ((items (org-ql--query ,files
(byte-compile (lambda () (byte-compile (lambda ()
@ -32,7 +35,8 @@ one or more sorting methods, including: `date', `deadline',
(<= #'<=) (<= #'<=)
(>= #'>=)) (>= #'>=))
,pred-body))) ,pred-body)))
,action-fn))) ,action-fn
:narrow ,narrow)))
(cl-typecase ',sort (cl-typecase ',sort
(list (org-ql--sort-by items ',sort)) (list (org-ql--sort-by items ',sort))
(function (funcall ,sort items)) (function (funcall ,sort items))
@ -48,7 +52,8 @@ one or more sorting methods, including: `date', `deadline',
;;;; Functions ;;;; Functions
(cl-defun org-ql--query (files pred action-fn) (cl-defun org-ql--query (files pred action-fn &key narrow)
"FIXME: Add docstring."
(setq files (cl-typecase files (setq files (cl-typecase files
(null (list (buffer-file-name (current-buffer)))) (null (list (buffer-file-name (current-buffer))))
(list files) (list files)
@ -60,13 +65,14 @@ one or more sorting methods, including: `date', `deadline',
(org-ql--today (org-today))) (org-ql--today (org-today)))
(-flatten-n 1 (--map (with-current-buffer (find-buffer-visiting it) (-flatten-n 1 (--map (with-current-buffer (find-buffer-visiting it)
(mapcar action-fn (mapcar action-fn
(org-ql--filter-buffer :pred pred))) (org-ql--filter-buffer :pred pred :narrow narrow)))
files)))) files))))
(cl-defun org-ql--filter-buffer (&key pred) (cl-defun org-ql--filter-buffer (&key pred narrow)
"Return positions of matching headings in current buffer. "Return positions of matching headings in current buffer.
Headings should return non-nil for any ANY-PREDS and nil for all Headings should return non-nil for any ANY-PREDS and nil for all
NONE-PREDS." 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. ;; Cache `org-today' so we don't have to run it repeatedly.
(cl-letf ((today org-ql--today)) (cl-letf ((today org-ql--today))
(org-ql--fmap ((category #'org-ql--category-p) (org-ql--fmap ((category #'org-ql--category-p)
@ -82,13 +88,16 @@ NONE-PREDS."
(property #'org-ql--property-p) (property #'org-ql--property-p)
(regexp #'org-ql--regexp-p) (regexp #'org-ql--regexp-p)
(org-back-to-heading #'outline-back-to-heading)) (org-back-to-heading #'outline-back-to-heading))
(org-with-wide-buffer (save-excursion
(save-restriction
(unless narrow
(widen))
(goto-char (point-min)) (goto-char (point-min))
(when (org-before-first-heading-p) (when (org-before-first-heading-p)
(outline-next-heading)) (outline-next-heading))
(cl-loop when (funcall pred) (cl-loop when (funcall pred)
collect (org-element-headline-parser (line-end-position)) collect (org-element-headline-parser (line-end-position))
while (outline-next-heading)))))) while (outline-next-heading)))))))
;;;;; Predicates ;;;;; Predicates