diff --git a/org-ql-search.el b/org-ql-search.el index f79b2541..1995a455 100644 --- a/org-ql-search.el +++ b/org-ql-search.el @@ -105,7 +105,7 @@ Runs `org-occur-hook' after making the sparse tree." num-results))) ;;;###autoload -(cl-defun org-ql-search (buffers-files query &key narrow super-groups sort title +(cl-defun org-ql-search (buffers-files query &key narrow super-groups sort title skip-subtrees (buffer org-ql-view-buffer)) "Search for QUERY with `org-ql'. Interactively, prompt for these variables: @@ -134,6 +134,8 @@ SORT: One or a list of `org-ql' sorting functions, like `date' or TITLE: An optional string displayed in the header. +SKIP-SUBTREES: Skip subtrees in matching entries. + BUFFER: Optionally, a buffer or name of a buffer in which to display the results. By default, the value of `org-ql-view-buffer' is used, and a new buffer is created if @@ -159,6 +161,7 @@ necessary." (read-string "Query: " (when org-ql-view-query (format "%S" org-ql-view-query))) :narrow (or org-ql-view-narrow (eq current-prefix-arg '(4))) + :skip-subtrees (yes-or-no-p "Skip subtrees?") :super-groups (when (bound-and-true-p org-super-agenda-auto-selector-keywords) (let ((keywords (cl-loop for type in org-super-agenda-auto-selector-keywords collect (substring (symbol-name type) 6)))) @@ -200,7 +203,8 @@ necessary." (results (org-ql-select buffers-files query :action 'element-with-markers :narrow narrow - :sort sort)) + :sort sort + :skip-subtrees skip-subtrees)) (strings (-map #'org-ql-view--format-element results)) (buffer (or buffer (format "%s %s*" org-ql-view-buffer-name-prefix (or title query)))) (header (org-ql-view--header-line-format buffers-files query title)) diff --git a/org-ql-view.el b/org-ql-view.el index e7f03296..97f68d28 100644 --- a/org-ql-view.el +++ b/org-ql-view.el @@ -87,6 +87,7 @@ Based on `org-agenda-mode-map'.") (defvar-local org-ql-view-query nil) (defvar-local org-ql-view-sort nil) (defvar-local org-ql-view-narrow nil) +(defvar-local org-ql-view-skip-subtrees nil) (defvar-local org-ql-view-super-groups nil) (defvar-local org-ql-view-title nil) @@ -218,12 +219,13 @@ Interactively, prompt for NAME." (select-window window)) (cl-typecase view (function (call-interactively view)) - (list (-let* (((&plist :buffers-files :query :sort :narrow :super-groups :title) view) + (list (-let* (((&plist :buffers-files :query :sort :narrow :super-groups :title :skip-subtrees) view) (super-groups (cl-typecase super-groups (symbol (symbol-value super-groups)) (list super-groups)))) (org-ql-search buffers-files query :super-groups super-groups :narrow narrow :sort sort :title title + :skip-subtrees skip-subtrees :buffer org-ql-view-buffer)))))) ;;;###autoload @@ -287,6 +289,7 @@ update search arguments." :sort org-ql-view-sort :narrow org-ql-view-narrow :super-groups org-ql-view-super-groups + :skip-subtrees org-ql-view-skip-subtrees :title org-ql-view-title)) (org-ql-view-buffer (current-buffer))) (if prompt @@ -309,6 +312,7 @@ update search arguments." :query org-ql-view-query :sort org-ql-view-sort :narrow org-ql-view-narrow + :skip-subtrees org-ql-view-skip-subtrees :super-groups org-ql-view-super-groups :title name))) (map-put org-ql-views name plist #'equal) diff --git a/org-ql.el b/org-ql.el index 22e37089..c0ff2d26 100644 --- a/org-ql.el +++ b/org-ql.el @@ -142,7 +142,7 @@ match." (cl-defun ,fn-name ,args ,docstring ,@body)))) ;;;###autoload -(cl-defmacro org-ql (buffers-or-files query &key sort narrow action) +(cl-defmacro org-ql (buffers-or-files query &key sort narrow action skip-subtrees) "Expands into a call to `org-ql-select' with the same arguments. For convenience, arguments should be unquoted." (declare (indent defun)) @@ -150,7 +150,8 @@ For convenience, arguments should be unquoted." ',query :action ',action :narrow ,narrow - :sort ',sort)) + :sort ',sort + :skip-subtrees ,skip-subtrees)) ;;;; Functions @@ -160,7 +161,7 @@ For convenience, arguments should be unquoted." (sxhash-equal (prin1-to-string args)))) ;;;###autoload -(cl-defun org-ql-select (buffers-or-files query &key action narrow sort) +(cl-defun org-ql-select (buffers-or-files query &key action narrow sort skip-subtrees) "Return items matching QUERY in BUFFERS-OR-FILES. BUFFERS-OR-FILES is a file or buffer, a list of files and/or @@ -191,7 +192,9 @@ SORT is either nil, in which case items are not sorted; or one or a list of defined `org-ql' sorting methods (`date', `deadline', `scheduled', `todo', `priority', or `random'); or a user-defined comparator function that accepts two items as arguments and -returns nil or non-nil." +returns nil or non-nil. + +If SKIP-SUBTREES is non-nil, subtrees of matching entries are skipped." (declare (indent defun)) (-let* ((buffers (->> (cl-typecase buffers-or-files (null (list (current-buffer))) @@ -235,8 +238,10 @@ returns nil or non-nil." (--map (with-current-buffer it (unless (derived-mode-p 'org-mode) (user-error "Not an Org buffer: %s" (buffer-name))) - (org-ql--select-cached :query query :preamble preamble :preamble-case-fold preamble-case-fold - :predicate predicate :action action :narrow narrow))) + (org-ql--select-cached :query query :preamble preamble + :preamble-case-fold preamble-case-fold + :predicate predicate :action action + :narrow narrow :skip-subtrees skip-subtrees))) (-flatten-n 1)))) ;; Sort items (pcase sort @@ -251,7 +256,7 @@ returns nil or non-nil." (_ (user-error "SORT must be either nil, one or a list of the defined sorting methods (see documentation), or a comparison function of two arguments"))))) ;;;###autoload -(cl-defun org-ql-query (&key (select 'element-with-markers) from where narrow order-by) +(cl-defun org-ql-query (&key (select 'element-with-markers) from where narrow order-by skip-subtrees) "Like `org-ql-select', but arguments are named more like a SQL query. SELECT corresponds to the `org-ql-select' argument ACTION. It is @@ -279,22 +284,26 @@ should be an `org-ql' query sexp. ORDER-BY corresponds to the `org-ql-select' argument SORT, which see. -NARROW corresponds to the `org-ql-select' argument NARROW." +NARROW corresponds to the `org-ql-select' argument NARROW. + +SKIP-SUBTREES corresponds to the `org-ql-select' argument +SKIP-SUBTREES." (declare (indent 0)) (org-ql-select from where :action select :narrow narrow - :sort order-by)) + :sort order-by + :skip-subtrees skip-subtrees)) (defun org-ql--select-cached (&rest args) "Return results for ARGS and current buffer using cache." ;; MAYBE: Timeout cached queries. Probably not necessarily since they will be removed when a ;; buffer is closed, or when a query is run after modifying a buffer. - (-let* (((&plist :query :preamble :action :narrow :preamble-case-fold) args) + (-let* (((&plist :query :preamble :action :narrow :preamble-case-fold :skip-subtrees) args) (query-cache-key ;; 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 + (list :query query :preamble preamble :action action :preamble-case-fold preamble-case-fold :skip-subtrees skip-subtrees (if narrow ;; Use bounds of narrowed portion of buffer. (cons (point-min) (point-max)) @@ -319,10 +328,11 @@ NARROW corresponds to the `org-ql-select' argument NARROW." (t (puthash query-cache-key (or new-result 'org-ql-nil) query-cache))) new-result)))) -(cl-defun org-ql--select (&key preamble preamble-case-fold predicate action narrow +(cl-defun org-ql--select (&key preamble preamble-case-fold predicate action narrow skip-subtrees &allow-other-keys) "Return results of mapping function ACTION across entries in current buffer matching function PREDICATE. -If NARROW is non-nil, buffer will not be widened." +If NARROW is non-nil, buffer will not be widened. +If SKIP-SUBTREES is non-nil, subtrees of matching entries are skipped." ;; Since the mappings are stored in the variable `org-ql-predicates', macros like `flet' ;; 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 @@ -361,9 +371,13 @@ If NARROW is non-nil, buffer will not be widened." do (outline-back-to-heading 'invisible-ok) when (funcall predicate) collect (funcall action) + when skip-subtrees + do (org-end-of-subtree) do (outline-next-heading)))) (t (cl-loop when (funcall predicate) collect (funcall action) + when skip-subtrees + do (org-end-of-subtree) while (outline-next-heading)))))))) (--each orig-fns ;; Restore original function mappings.