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

Merge f9a80225e2 into 538373bb48

Browse source
This commit is contained in:
Akira Komamura 2020-01-24 08:19:35 -05:00 • committed by GitHub
commit 6d44a7e447
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
3 changed files with 38 additions and 16 deletions
Download patch file Download diff file Expand all files Collapse all files

8
org-ql-search.el
View file

@ -105,7 +105,7 @@ Runs `org-occur-hook' after making the sparse tree."
num-results))) num-results)))
;;;###autoload ;;;###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)) (buffer org-ql-view-buffer))
"Search for QUERY with `org-ql'. "Search for QUERY with `org-ql'.
Interactively, prompt for these variables: 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. 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 BUFFER: Optionally, a buffer or name of a buffer in which to
display the results. By default, the value of display the results. By default, the value of
`org-ql-view-buffer' is used, and a new buffer is created if `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 (read-string "Query: " (when org-ql-view-query
(format "%S" org-ql-view-query))) (format "%S" org-ql-view-query)))
:narrow (or org-ql-view-narrow (eq current-prefix-arg '(4))) :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) :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 (let ((keywords (cl-loop for type in org-super-agenda-auto-selector-keywords
collect (substring (symbol-name type) 6)))) collect (substring (symbol-name type) 6))))
@ -200,7 +203,8 @@ necessary."
(results (org-ql-select buffers-files query (results (org-ql-select buffers-files query
:action 'element-with-markers :action 'element-with-markers
:narrow narrow :narrow narrow
:sort sort)) :sort sort
:skip-subtrees skip-subtrees))
(strings (-map #'org-ql-view--format-element results)) (strings (-map #'org-ql-view--format-element results))
(buffer (or buffer (format "%s %s*" org-ql-view-buffer-name-prefix (or title query)))) (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)) (header (org-ql-view--header-line-format buffers-files query title))

6
org-ql-view.el
View file

@ -88,6 +88,7 @@ Based on `org-agenda-mode-map'.")
(defvar-local org-ql-view-query nil) (defvar-local org-ql-view-query nil)
(defvar-local org-ql-view-sort nil) (defvar-local org-ql-view-sort nil)
(defvar-local org-ql-view-narrow 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-super-groups nil)
(defvar-local org-ql-view-title nil) (defvar-local org-ql-view-title nil)
@ -247,12 +248,13 @@ Interactively, prompt for NAME."
(select-window window)) (select-window window))
(cl-typecase view (cl-typecase view
(function (call-interactively 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 (super-groups (cl-typecase super-groups
(symbol (symbol-value super-groups)) (symbol (symbol-value super-groups))
(list super-groups)))) (list super-groups))))
(org-ql-search buffers-files query (org-ql-search buffers-files query
:super-groups super-groups :narrow narrow :sort sort :title title :super-groups super-groups :narrow narrow :sort sort :title title
:skip-subtrees skip-subtrees
:buffer org-ql-view-buffer)))))) :buffer org-ql-view-buffer))))))
;;;###autoload ;;;###autoload
@ -316,6 +318,7 @@ update search arguments."
:sort org-ql-view-sort :sort org-ql-view-sort
:narrow org-ql-view-narrow :narrow org-ql-view-narrow
:super-groups org-ql-view-super-groups :super-groups org-ql-view-super-groups
:skip-subtrees org-ql-view-skip-subtrees
:title org-ql-view-title)) :title org-ql-view-title))
(org-ql-view-buffer (current-buffer))) (org-ql-view-buffer (current-buffer)))
(if prompt (if prompt
@ -339,6 +342,7 @@ update search arguments."
:query org-ql-view-query :query org-ql-view-query
:sort org-ql-view-sort :sort org-ql-view-sort
:narrow org-ql-view-narrow :narrow org-ql-view-narrow
:skip-subtrees org-ql-view-skip-subtrees
:super-groups org-ql-view-super-groups :super-groups org-ql-view-super-groups
:title name))) :title name)))
(setf (map-elt org-ql-views name nil #'equal) plist) (setf (map-elt org-ql-views name nil #'equal) plist)

40
org-ql.el
View file

@ -142,7 +142,7 @@ match."
(cl-defun ,fn-name ,args ,docstring ,@body)))) (cl-defun ,fn-name ,args ,docstring ,@body))))
;;;###autoload ;;;###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. "Expands into a call to `org-ql-select' with the same arguments.
For convenience, arguments should be unquoted." For convenience, arguments should be unquoted."
(declare (indent defun)) (declare (indent defun))
@ -150,7 +150,8 @@ For convenience, arguments should be unquoted."
',query ',query
:action ',action :action ',action
:narrow ,narrow :narrow ,narrow
:sort ',sort)) :sort ',sort
:skip-subtrees ,skip-subtrees))
;;;; Functions ;;;; Functions
@ -160,7 +161,7 @@ For convenience, arguments should be unquoted."
(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 (buffers-or-files query &key action narrow sort skip-subtrees)
"Return items matching QUERY in BUFFERS-OR-FILES. "Return items matching QUERY in BUFFERS-OR-FILES.
BUFFERS-OR-FILES is a file or buffer, a list of files and/or 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', a list of defined `org-ql' sorting methods (`date', `deadline',
`scheduled', `todo', `priority', or `random'); or a user-defined `scheduled', `todo', `priority', or `random'); or a user-defined
comparator function that accepts two items as arguments and 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)) (declare (indent defun))
(-let* ((buffers (->> (cl-typecase buffers-or-files (-let* ((buffers (->> (cl-typecase buffers-or-files
(null (list (current-buffer))) (null (list (current-buffer)))
@ -235,8 +238,10 @@ returns nil or non-nil."
(--map (with-current-buffer it (--map (with-current-buffer it
(unless (derived-mode-p 'org-mode) (unless (derived-mode-p 'org-mode)
(user-error "Not an Org buffer: %s" (buffer-name))) (user-error "Not an Org buffer: %s" (buffer-name)))
(org-ql--select-cached :query query :preamble preamble :preamble-case-fold preamble-case-fold (org-ql--select-cached :query query :preamble preamble
:predicate predicate :action action :narrow narrow))) :preamble-case-fold preamble-case-fold
:predicate predicate :action action
:narrow narrow :skip-subtrees skip-subtrees)))
(-flatten-n 1)))) (-flatten-n 1))))
;; Sort items ;; Sort items
(pcase sort (pcase sort
@ -250,7 +255,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"))))) (_ (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 ;;;###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. "Like `org-ql-select', but arguments are named more like a SQL query.
SELECT corresponds to the `org-ql-select' argument ACTION. It is SELECT corresponds to the `org-ql-select' argument ACTION. It is
@ -278,22 +283,26 @@ should be an `org-ql' query sexp.
ORDER-BY corresponds to the `org-ql-select' argument SORT, which ORDER-BY corresponds to the `org-ql-select' argument SORT, which
see. 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)) (declare (indent 0))
(org-ql-select from where (org-ql-select from where
:action select :action select
:narrow narrow :narrow narrow
:sort order-by)) :sort order-by
:skip-subtrees skip-subtrees))
(defun org-ql--select-cached (&rest args) (defun org-ql--select-cached (&rest args)
"Return results for ARGS and current buffer using cache." "Return results for ARGS and current buffer using cache."
;; MAYBE: Timeout cached queries. Probably not necessarily since they will be removed when a ;; 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. ;; 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 (query-cache-key
;; 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 :skip-subtrees skip-subtrees
(if narrow (if narrow
;; Use bounds of narrowed portion of buffer. ;; Use bounds of narrowed portion of buffer.
(cons (point-min) (point-max)) (cons (point-min) (point-max))
@ -318,10 +327,11 @@ NARROW corresponds to the `org-ql-select' argument NARROW."
(t (puthash query-cache-key (or new-result 'org-ql-nil) query-cache))) (t (puthash query-cache-key (or new-result 'org-ql-nil) query-cache)))
new-result)))) 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) &allow-other-keys)
"Return results of mapping function ACTION across entries in current buffer matching function PREDICATE. "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' ;; 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). ;; 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
@ -360,9 +370,13 @@ If NARROW is non-nil, buffer will not be widened."
do (outline-back-to-heading 'invisible-ok) do (outline-back-to-heading 'invisible-ok)
when (funcall predicate) when (funcall predicate)
collect (funcall action) collect (funcall action)
when skip-subtrees
do (org-end-of-subtree)
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)
when skip-subtrees
do (org-end-of-subtree)
while (outline-next-heading)))))))) while (outline-next-heading))))))))
(--each orig-fns (--each orig-fns
;; Restore original function mappings. ;; Restore original function mappings.