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

WIP: Accept entry IDs as IN argument

Browse source
This commit is contained in:
Adam Porter 2023-12-14 17:53:02 -06:00
parent 39394c831a
commit e57d50b81c
1 changed files with 85 additions and 59 deletions
Download patch file Download diff file Expand all files Collapse all files

78
org-ql.el
View file

@ -333,11 +333,12 @@ See Info node `(org-ql)Queries'."
(sxhash-equal (prin1-to-string args)))) (sxhash-equal (prin1-to-string args))))
;;;###autoload ;;;###autoload
(cl-defun org-ql-select (buffers-or-files query &key action narrow sort) (cl-defun org-ql-select (in query &key action narrow sort)
"Return items matching QUERY in BUFFERS-OR-FILES. "Return items matching QUERY in IN.
BUFFERS-OR-FILES is a file or buffer, a list of files and/or IN is a buffer, file, or Org entry ID string (i.e. findable with
buffers, or a function which returns such a list. `org-id-goto'), or a list of one or more of such items, or a
function which returns such a list.
QUERY is an `org-ql' query sexp (quoted, since this is a QUERY is an `org-ql' query sexp (quoted, since this is a
function). function).
@ -374,23 +375,28 @@ would appear first. In contrast, `(date reverse priority)' would
also present items with the highest priority first, but within also present items with the highest priority first, but within
each priority the newest items would appear first." each priority the newest items would appear first."
(declare (indent defun)) (declare (indent defun))
(-let* ((buffers (->> (cl-typecase buffers-or-files (-let* ((in (->> (cl-typecase in
(null (list (current-buffer))) (null (list (current-buffer)))
(function (funcall buffers-or-files)) (function (funcall in))
(list buffers-or-files) (list in)
(otherwise (list buffers-or-files))) (otherwise (list in)))
(--map (cl-etypecase it (--map (pcase-exhaustive it
;; NOTE: This etypecase is essential to opening links safely, ;; NOTE: This exhaustive pcase is essential to opening links safely,
;; as it rejects, e.g. lambdas in the buffers-files argument. ;; as it rejects, e.g. lambdas in the buffers-files argument.
(buffer it) ((cl-type buffer) it)
(string (or (find-buffer-visiting it) ((and (cl-type string)
(pred file-readable-p))
(or (find-buffer-visiting it)
(when (file-readable-p it) (when (file-readable-p it)
;; It feels unintuitive that `find-file-noselect' returns ;; It feels unintuitive that `find-file-noselect' returns
;; a buffer if the filename doesn't exist. ;; a buffer if the filename doesn't exist.
(find-file-noselect it)) (find-file-noselect it))
(display-warning 'org-ql-select (format "Can't open file: %s" it) :error))))) (display-warning 'org-ql-select (format "Can't open file: %s" it) :error)))
((cl-type string)
;; Assumed to be an Org ID string (without the "id:" prefix).
it)))
;; Ignore special/hidden buffers. ;; Ignore special/hidden buffers.
(--remove (string-prefix-p " " (buffer-name it))))) (--remove (and (bufferp it) (string-prefix-p " " (buffer-name it))))))
(query (org-ql--normalize-query query)) (query (org-ql--normalize-query query))
((&plist :query :preamble :preamble-case-fold) (org-ql--query-preamble query)) ((&plist :query :preamble :preamble-case-fold) (org-ql--query-preamble query))
(predicate (org-ql--query-predicate query)) (predicate (org-ql--query-predicate query))
@ -425,12 +431,19 @@ each priority the newest items would appear first."
;; Temporarily set new function definition. ;; Temporarily set new function definition.
(fset name fn))) (fset name fn)))
;; Run query on buffers. ;; Run query on buffers.
(->> buffers (->> in
(--map (with-current-buffer it (--map (let* ((marker)
(buffer (cl-etypecase it
(buffer it)
(string (marker-buffer
(setf marker (org-id-find it 'as-marker)))))))
(with-current-buffer buffer
(unless (derived-mode-p 'org-mode) (unless (derived-mode-p 'org-mode)
(display-warning 'org-ql-select (format "Not an Org buffer: %s" (buffer-name)) :error)) (display-warning 'org-ql-select (format "Not an Org buffer: %s" (buffer-name)) :error))
(org-ql--select-cached :query query :preamble preamble :preamble-case-fold preamble-case-fold (org-ql--select-cached :query query :preamble preamble :preamble-case-fold preamble-case-fold
:predicate predicate :action action :narrow narrow))) :predicate predicate :action action
;; FIXME: Is it okay to use a marker here, or do we need to use the ID and get a new position each time?
:narrow (or marker narrow)))))
(-flatten-n 1))) (-flatten-n 1)))
(--each orig-fns (--each orig-fns
;; Restore original function mappings. ;; Restore original function mappings.
@ -466,8 +479,7 @@ are returned by this function. It may be:
- A function symbol. - A function symbol.
FROM corresponds to the `org-ql-select' argument BUFFERS-OR-FILES. FROM corresponds to the `org-ql-select' argument IN, which see.
It may be one or a list of file paths and/or buffers.
WHERE corresponds to the `org-ql-select' argument QUERY. It WHERE corresponds to the `org-ql-select' argument QUERY. It
should be an `org-ql' query sexp. should be an `org-ql' query sexp.
@ -491,10 +503,12 @@ NARROW corresponds to the `org-ql-select' argument NARROW."
;; The key must include the preamble, because some queries are replaced by ;; The key must include the preamble, because some queries are replaced by
;; the preamble, leaving a nil query, which would make the key ambiguous. ;; the preamble, leaving a nil query, which would make the key ambiguous.
(list :query query :preamble preamble :action action :preamble-case-fold preamble-case-fold (list :query query :preamble preamble :action action :preamble-case-fold preamble-case-fold
(if narrow :narrow (pcase-exhaustive narrow
;; Use bounds of narrowed portion of buffer. ((cl-type string) narrow)
(cons (point-min) (point-max)) ((cl-type marker) narrow)
nil)))) (`t ;; Use bounds of narrowed portion of buffer.
(cons (point-min) (point-max)))
(`nil nil)))))
(if-let* ((buffer-cache (gethash (current-buffer) org-ql-cache)) (if-let* ((buffer-cache (gethash (current-buffer) org-ql-cache))
(query-cache (cadr buffer-cache)) (query-cache (cadr buffer-cache))
(modified-tick (car buffer-cache)) (modified-tick (car buffer-cache))
@ -529,10 +543,18 @@ PREAMBLE-CASE-FOLD."
;; can't be used, so we do it manually (this is same as the equivalent `flet' expansion). ;; can't be used, so we do it manually (this is same as the equivalent `flet' expansion).
;; Mappings are stored in the variable because it allows predicates to be defined with a ;; Mappings are stored in the variable because it allows predicates to be defined with a
;; macro, which allows documentation to be easily generated for them. ;; macro, which allows documentation to be easily generated for them.
(let (old-restriction)
(save-excursion (save-excursion
(save-restriction (save-restriction
(unless narrow (pcase narrow
(widen)) ((cl-type marker)
(switch-to-buffer (marker-buffer narrow)) ;; Can change buffer!
(setf old-restriction (if (buffer-narrowed-p)
(cons (point-min) (point-max))
t))
(goto-char narrow)
(org-narrow-to-subtree))
(`nil (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))
@ -546,6 +568,7 @@ PREAMBLE-CASE-FOLD."
nil) nil)
;; Find matching entries. ;; Find matching entries.
;; TODO: Bind `case-fold-search' around the preamble loop. ;; TODO: Bind `case-fold-search' around the preamble loop.
(unwind-protect
(cond (preamble (cl-loop while (let ((case-fold-search preamble-case-fold)) (cond (preamble (cl-loop while (let ((case-fold-search preamble-case-fold))
(re-search-forward preamble nil t)) (re-search-forward preamble nil t))
do (outline-back-to-heading 'invisible-ok) do (outline-back-to-heading 'invisible-ok)
@ -554,7 +577,10 @@ PREAMBLE-CASE-FOLD."
do (outline-next-heading))) do (outline-next-heading)))
(t (cl-loop when (funcall predicate) (t (cl-loop when (funcall predicate)
collect (funcall action) collect (funcall action)
while (outline-next-heading)))))))) while (outline-next-heading))))
(pcase old-restriction
(`t (widen))
(`(,start . ,end) (narrow-to-region start end)))))))))
;;;;; Helpers ;;;;; Helpers