Skip to content

Commit

Permalink
WIP: Accept entry IDs as IN argument
Browse files Browse the repository at this point in the history
  • Loading branch information
@alphapapa
alphapapa committed Dec 14, 2023
1 parent 4f62ba3 commit 92efb5c
Showing 1 changed file with 86 additions and 60 deletions.
146 changes: 86 additions & 60 deletions org-ql.el
View file
Original file line number Diff line number Diff line change
Expand Up @@ -321,11 +321,12 @@ See Info node `(org-ql)Queries'."
(sxhash-equal (prin1-to-string args))))

;;;###autoload
(cl-defun org-ql-select (buffers-or-files query &key action narrow sort)
"Return items matching QUERY in BUFFERS-OR-FILES.
(cl-defun org-ql-select (in query &key action narrow sort)
"Return items matching QUERY in IN.
BUFFERS-OR-FILES is a file or buffer, a list of files and/or
buffers, or a function which returns such a list.
IN is a buffer, file, or Org entry ID string (i.e. findable with
`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
function).
Expand All @@ -345,7 +346,7 @@ point at the beginning of its heading. It may be:
- A function symbol.
If NARROW is non-nil, buffers are not widened (the default is to
If NARROW is non-nil, in are not widened (the default is to
widen and search the entire buffer).
SORT is either nil, in which case items are not sorted; or one or
Expand All @@ -362,23 +363,28 @@ would appear first. In contrast, `(date reverse priority)' would
also present items with the highest priority first, but within
each priority the newest items would appear first."
(declare (indent defun))
(-let* ((buffers (->> (cl-typecase buffers-or-files
(null (list (current-buffer)))
(function (funcall buffers-or-files))
(list buffers-or-files)
(otherwise (list buffers-or-files)))
(--map (cl-etypecase it
;; NOTE: This etypecase is essential to opening links safely,
;; as it rejects, e.g. lambdas in the buffers-files argument.
(buffer it)
(string (or (find-buffer-visiting it)
(when (file-readable-p it)
;; It feels unintuitive that `find-file-noselect' returns
;; a buffer if the filename doesn't exist.
(find-file-noselect it))
(display-warning 'org-ql-select (format "Can't open file: %s" it) :error)))))
;; Ignore special/hidden buffers.
(--remove (string-prefix-p " " (buffer-name it)))))
(-let* ((in (->> (cl-typecase in
(null (list (current-buffer)))
(function (funcall in))
(list in)
(otherwise (list in)))
(--map (pcase-exhaustive it
;; NOTE: This etypecase is essential to opening links safely,
;; as it rejects, e.g. lambdas in the buffers-files argument.
((cl-type buffer) it)
((and (cl-type string)
(pred file-readable-p))
(or (find-buffer-visiting it)
(when (file-readable-p it)
;; It feels unintuitive that `find-file-noselect' returns
;; a buffer if the filename doesn't exist.
(find-file-noselect it))
(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.
(--remove (and (bufferp it) (string-prefix-p " " (buffer-name it))))))
(query (org-ql--normalize-query query))
((&plist :query :preamble :preamble-case-fold) (org-ql--query-preamble query))
(predicate (org-ql--query-predicate query))
Expand Down Expand Up @@ -413,12 +419,19 @@ each priority the newest items would appear first."
;; Temporarily set new function definition.
(fset name fn)))
;; Run query on buffers.
(->> buffers
(--map (with-current-buffer it
(unless (derived-mode-p 'org-mode)
(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
:predicate predicate :action action :narrow narrow)))
(->> in
(--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)
(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
: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)))
(--each orig-fns
;; Restore original function mappings.
Expand Down Expand Up @@ -454,8 +467,7 @@ are returned by this function. It may be:
- A function symbol.
FROM corresponds to the `org-ql-select' argument BUFFERS-OR-FILES.
It may be one or a list of file paths and/or buffers.
FROM corresponds to the `org-ql-select' argument IN, which see.
WHERE corresponds to the `org-ql-select' argument QUERY. It
should be an `org-ql' query sexp.
Expand All @@ -479,10 +491,12 @@ NARROW corresponds to the `org-ql-select' argument NARROW."
;; The key must include the preamble, because some queries are replaced by
;; 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
(if narrow
;; Use bounds of narrowed portion of buffer.
(cons (point-min) (point-max))
nil))))
:narrow (pcase-exhaustive narrow
((cl-type string) narrow)
((cl-type marker) narrow)
(`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))
(query-cache (cadr buffer-cache))
(modified-tick (car buffer-cache))
Expand Down Expand Up @@ -517,32 +531,44 @@ PREAMBLE-CASE-FOLD."
;; 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
;; macro, which allows documentation to be easily generated for them.
(save-excursion
(save-restriction
(unless narrow
(widen))
(goto-char (point-min))
(when (org-before-first-heading-p)
(outline-next-heading))
(if (not (org-at-heading-p))
(progn
;; No headings in buffer: return nil.
(unless (string-prefix-p " " (buffer-name))
;; Not a special, hidden buffer: show message, because if a user accidentally
;; searches a buffer without headings, he might be confused.
(message "org-ql: No headings in buffer: %s" (current-buffer)))
nil)
;; Find matching entries.
;; TODO: Bind `case-fold-search' around the preamble loop.
(cond (preamble (cl-loop while (let ((case-fold-search preamble-case-fold))
(re-search-forward preamble nil t))
do (outline-back-to-heading 'invisible-ok)
when (funcall predicate)
collect (funcall action)
do (outline-next-heading)))
(t (cl-loop when (funcall predicate)
collect (funcall action)
while (outline-next-heading))))))))
(let (old-restriction)
(save-excursion
(save-restriction
(pcase narrow
((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))
(when (org-before-first-heading-p)
(outline-next-heading))
(if (not (org-at-heading-p))
(progn
;; No headings in buffer: return nil.
(unless (string-prefix-p " " (buffer-name))
;; Not a special, hidden buffer: show message, because if a user accidentally
;; searches a buffer without headings, he might be confused.
(message "org-ql: No headings in buffer: %s" (current-buffer)))
nil)
;; Find matching entries.
;; TODO: Bind `case-fold-search' around the preamble loop.
(unwind-protect
(cond (preamble (cl-loop while (let ((case-fold-search preamble-case-fold))
(re-search-forward preamble nil t))
do (outline-back-to-heading 'invisible-ok)
when (funcall predicate)
collect (funcall action)
do (outline-next-heading)))
(t (cl-loop when (funcall predicate)
collect (funcall action)
while (outline-next-heading))))
(pcase old-restriction
(`t (widen))
(`(,start . ,end) (narrow-to-region start end)))))))))

;;;;; Helpers

Expand Down

0 comments on commit 92efb5c

Please sign in to comment.