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

Add: Tag cache, inherited/local tags predicates

Browse source
This commit is contained in:
Adam Porter 2019-09-05 08:22:41 -05:00
parent 3ec5e08a6b
commit ca9ab3e6a5
3 changed files with 153 additions and 10 deletions
Download patch file Download diff file Expand all files Collapse all files

10
README.org
View file

@ -216,7 +216,11 @@ Arguments are listed next to predicate names, where applicable.
+ ~priority (&optional comparator-or-priority priority)~ :: Return non-nil if current heading has a certain priority. ~COMPARATOR-OR-PRIORITY~ should be either a comparator function, like ~<=~, or a priority string, like "A" (in which case (~=~ will be the comparator). If ~COMPARATOR-OR-PRIORITY~ is a comparator, ~PRIORITY~ should be a priority string. If both arguments are nil, return non-nil if heading has any defined priority.
+ ~property (property &optional value)~ :: Return non-nil if current entry has ~PROPERTY~ (a string), and optionally ~VALUE~ (a string). Note that property inheritance is currently /not/ enabled for this predicate. If you need to test with inheritance, you could use a custom predicate form, like ~(org-entry-get (point) "PROPERTY" 'inherit)~.
+ ~regexp (regexp)~ :: Return non-nil if current entry matches ~REGEXP~ (a regexp string). Matches against entire entry, from beginning of its heading to the next heading.
+ ~tags (&optional tags)~ :: Return non-nil if current heading has one or more of ~TAGS~ (a list of strings).
+ ~tags (&optional tags)~ :: Return non-nil if current heading has one or more of ~TAGS~ (a list of strings). Tests both inherited and local tags.
+ =tags-inherited (&optional tags)= :: Return non-nil if current heading's inherited tags include one or more of =TAGS= (a list of strings). If TAGS is nil, return non-nil if heading has any inherited tags.
- Aliases: =inherited-tags=, =tags-i=, =itags=.
+ =tags-local (&optional tags)= :: Return non-nil if current heading's local tags include one or more of =TAGS= (a list of strings). If TAGS is nil, return non-nil if heading has any local tags.
- Aliases: =local-tags=, =tags-l=, =ltags=.
+ ~todo (&optional keywords)~ :: Return non-nil if current heading is a ~TODO~ item. With ~KEYWORDS~, return non-nil if its keyword is one of ~KEYWORDS~ (a list of strings). When called without arguments, only matches non-done tasks (i.e. does not match keywords in ~org-done-keywords~).
*** Date/time predicates
@ -453,6 +457,10 @@ Expands into a call to ~org-ql-select~ with the same arguments. For convenience
*Added*
+ Command =org-ql-sparse-tree=, like =org-sparse-tree= for =org-ql= queries. (Thanks to [[https://github.com/akirak][Akira Komamura]].)
+ Per-buffer, per-heading tag caching, which increases the speed of tags-related queries by 6-7x.
+ More tags-related predicates and aliases:
- For inherited tags: =tags-inherited=, =inherited-tags=, =tags-i=, =itags=.
- For heading-local tags: =tags-local=, =local-tags=, =tags-l=, =ltags=.
** 0.2
:PROPERTIES:

106
org-ql.el
View file

@ -90,6 +90,13 @@ Each value is a list of the buffer's modified tick and another
hash table, keyed by arguments passed to
`org-ql--select-cached'.")
(defvar org-ql-tags-cache (make-hash-table :weakness 'key)
"Per-buffer tags cache.
Keyed by buffer. Each value is a cons of the buffer's modified
tick, and another hash table keyed on buffer position, whose
values are a list of two lists, inherited tags and local tags, as
strings.")
(defvar org-ql-predicates
(list (list :name 'org-back-to-heading :fn (symbol-function 'org-back-to-heading)))
"Plist of predicates, their corresponding functions, and their docstrings.
@ -323,6 +330,10 @@ Replaces bare strings with (regexp) selectors, and appropriate
;; Quote comparator.
`(priority ',comparator ,letter))
;; Tags: inherited and local predicate aliases.
(`(,(or 'tags-i 'itags 'inherited-tags) . ,tags) `(tags-inherited ,@tags))
(`(,(or 'tags-l 'ltags 'local-tags) . ,tags) `(tags-local ,@tags))
;; Timestamps
(`(,(or 'ts-active 'ts-a) . ,rest) `(ts :type active ,@rest))
(`(,(or 'ts-inactive 'ts-i) . ,rest) `(ts :type inactive ,@rest))
@ -509,10 +520,9 @@ replace the clause with a preamble."
(setq org-ql-preamble org-scheduled-time-regexp)
;; Return element, because the predicate still needs testing.
element)
;; TODO: Add selector for tags without inheritance.
((and `(tags . ,tags) (guard (not org-use-tag-inheritance)))
;; When tag inheritance is disabled, we only consider direct tags,
;; so we can search directly to headings containing one of the tags.
(`((or 'tags-local 'local-tags 'tags-l 'ltags) . ,tags)
;; When searching for local, non-inherited tags, we can
;; search directly to headings containing one of the tags.
(setq org-ql-preamble (rx-to-string `(seq bol (1+ "*") (1+ space) (1+ not-newline)
":" (or ,@tags) ":")
t))
@ -621,6 +631,50 @@ If NARROW is non-nil, buffer will not be widened."
;; Restore original function mappings.
(fset (plist-get it :name) (plist-get it :fn))))))
(defun org-ql--tags-at (position)
"Return tags for POSITION in current buffer.
Returns cons (INHERITED-TAGS . LOCAL-TAGS)."
;; I'd like to use `-if-let*', but it doesn't leave non-nil variables
;; bound in the else clause, so destructured variables that are non-nil,
;; like found caches, are not available in the else clause.
(if-let* ((buffer-cache (gethash (current-buffer) org-ql-tags-cache))
(modified-tick (car buffer-cache))
(tags-cache (cdr buffer-cache))
(buffer-unmodified-p (eq (buffer-modified-tick) modified-tick))
(cached-result (gethash position tags-cache)))
;; Found in cache: return them.
(pcase cached-result
('org-ql-nil nil)
(_ cached-result))
;; Not found in cache: get tags and cache them.
(let* ((local-tags (or (org-ql--get-tags position 'local)
'org-ql-nil))
(inherited-tags (or (save-excursion
(when (org-up-heading-safe)
(-let* (((inherited local) (org-ql--tags-at (point))))
(when (or inherited local)
(cond ((and (listp inherited)
(listp local))
(->> (append inherited local)
-non-nil -uniq))
((listp inherited) inherited)
((listp local) local))))))
'org-ql-nil))
(all-tags (list inherited-tags local-tags)))
;; Check caches again, because they may have been set now.
;; TODO: Is there a clever way we could avoid doing this, or is it inherently necessary?
(setf buffer-cache (gethash (current-buffer) org-ql-tags-cache)
modified-tick (car buffer-cache)
tags-cache (cdr buffer-cache)
buffer-unmodified-p (eq (buffer-modified-tick) modified-tick))
(unless (and buffer-cache buffer-unmodified-p)
;; Buffer-local tags cache empty or invalid: make new one.
(setf tags-cache (make-hash-table))
(puthash (current-buffer)
(cons (buffer-modified-tick) tags-cache)
org-ql-tags-cache))
(puthash position all-tags tags-cache))))
;;;;; Helpers
(defun org-ql--add-markers (element)
@ -713,13 +767,49 @@ With KEYWORDS, return non-nil if its keyword is one of KEYWORDS (a list of strin
(or (apply #'org-ql--predicate-todo org-done-keywords)))
(org-ql--defpred tags (&rest tags)
"Return non-nil if current heading has one or more of TAGS (a list of strings)."
"Return non-nil if current heading has one or more of TAGS (a list of strings).
Tests both inherited and local tags."
;; TODO: Try to use `org-make-tags-matcher' to improve performance. It would be nice to not have
;; to run `org-get-tags' for every heading, especially with inheritance.
(when-let ((tags-at (org-ql--get-tags (point) (not org-use-tag-inheritance))))
(cl-macrolet ((tags-p (tags)
`(and ,tags
(not (eq 'org-ql-nil ,tags)))))
(-let* (((inherited local) (org-ql--tags-at (point))))
(cl-typecase tags
(null t)
(otherwise (seq-intersection tags tags-at)))))
(null (or (tags-p inherited)
(tags-p local)))
(otherwise (or (when (tags-p inherited)
(seq-intersection tags inherited))
(when (tags-p local)
(seq-intersection tags local))))))))
(org-ql--defpred tags-inherited (&rest tags)
"Return non-nil if current heading's inherited tags include one or more of TAGS (a list of strings).
If TAGS is nil, return non-nil if heading has any inherited tags."
;; TODO: Try to use `org-make-tags-matcher' to improve performance. It would be nice to not have
;; to run `org-get-tags' for every heading, especially with inheritance.
(cl-macrolet ((tags-p (tags)
`(and ,tags
(not (eq 'org-ql-nil ,tags)))))
(-let* (((inherited _) (org-ql--tags-at (point))))
(cl-typecase tags
(null (tags-p inherited))
(otherwise (when (tags-p inherited)
(seq-intersection tags inherited)))))))
(org-ql--defpred tags-local (&rest tags)
"Return non-nil if current heading's local tags include one or more of TAGS (a list of strings).
If TAGS is nil, return non-nil if heading has any local tags."
;; TODO: Try to use `org-make-tags-matcher' to improve performance. It would be nice to not have
;; to run `org-get-tags' for every heading, especially with inheritance.
(cl-macrolet ((tags-p (tags)
`(and ,tags
(not (eq 'org-ql-nil ,tags)))))
(-let* (((_ local) (org-ql--tags-at (point))))
(cl-typecase tags
(null (tags-p local))
(otherwise (when (tags-p local)
(seq-intersection tags local)))))))
(org-ql--defpred level (level-or-comparator &optional level)
"Return non-nil if current heading's outline level matches arguments.

45
tests/test-org-ql.el
View file

@ -586,6 +586,51 @@ RESULTS should be a list of strings as returned by
(org-ql-expect ((not (tags "Emacs" "space")))
'("Test data" "Take over the universe" "Take over the world" "Skype with president of Antarctica" "Take over Mars" "Take over the moon" "Practice leaping tall buildings in a single bound" "Renew membership in supervillain club" "Learn universal sign language" "Order a pizza" "Get haircut" "Internet" "Spaceship lease" "Fix flux capacitor" "Recurring" "Shop for groceries" "Sunrise/sunset" "Ideas" "Write a symphony" "Code" "Agenda examining" "Agenda censoring" "Auto grouping" "Auto categories" "Date" "Effort" "Misc" "let-plist" "Profiling"))))
(describe "(tags-inherited)"
(org-ql-it "without arguments"
(org-ql-expect ((tags-inherited))
'("Take over the world" "Skype with president of Antarctica" "Take over Mars" "Visit Mars" "Take over the moon" "Visit the moon" "Practice leaping tall buildings in a single bound" "Renew membership in supervillain club" "Learn universal sign language"))
(org-ql-expect ((not (inherited-tags)))
'("Test data" "Take over the universe" "Order a pizza" "Get haircut" "Internet" "Spaceship lease" "Fix flux capacitor" "Recurring" "/r/emacs" "Shop for groceries" "Sunrise/sunset" "Ideas" "Rewrite Emacs in Common Lisp" "Write a symphony" "Code" "Agenda examining" "Agenda censoring" "Auto grouping" "Auto categories" "Date" "Effort" "Misc" "let-plist" "Profiling")))
(org-ql-it "with a tag"
(org-ql-expect ((tags-inherited "Emacs"))
nil)
(org-ql-expect ((itags "ambition"))
'("Take over the world" "Skype with president of Antarctica" "Take over Mars" "Visit Mars" "Take over the moon" "Visit the moon" "Practice leaping tall buildings in a single bound" "Renew membership in supervillain club" "Learn universal sign language"))
(org-ql-expect ((not (tags-i "ambition")))
'("Test data" "Take over the universe" "Order a pizza" "Get haircut" "Internet" "Spaceship lease" "Fix flux capacitor" "Recurring" "/r/emacs" "Shop for groceries" "Sunrise/sunset" "Ideas" "Rewrite Emacs in Common Lisp" "Write a symphony" "Code" "Agenda examining" "Agenda censoring" "Auto grouping" "Auto categories" "Date" "Effort" "Misc" "let-plist" "Profiling")))
(org-ql-it "with 2 tags"
(org-ql-expect ((itags "personal" "world"))
'("Skype with president of Antarctica"))
(org-ql-expect ((not (tags-inherited "personal" "world")))
;; Note that this correctly includes the task "Practice leaping...", which has the LOCAL tag "personal".
'("Test data" "Take over the universe" "Take over the world" "Take over Mars" "Visit Mars" "Take over the moon" "Visit the moon" "Practice leaping tall buildings in a single bound" "Renew membership in supervillain club" "Learn universal sign language" "Order a pizza" "Get haircut" "Internet" "Spaceship lease" "Fix flux capacitor" "Recurring" "/r/emacs" "Shop for groceries" "Sunrise/sunset" "Ideas" "Rewrite Emacs in Common Lisp" "Write a symphony" "Code" "Agenda examining" "Agenda censoring" "Auto grouping" "Auto categories" "Date" "Effort" "Misc" "let-plist" "Profiling"))))
(describe "(tags-local)"
(org-ql-it "without arguments"
(org-ql-expect ((tags-local))
'("Take over the universe" "Take over the world" "Skype with president of Antarctica" "Visit Mars" "Visit the moon" "Practice leaping tall buildings in a single bound" "Order a pizza" "Get haircut" "Internet" "Spaceship lease" "Fix flux capacitor" "/r/emacs" "Shop for groceries" "Rewrite Emacs in Common Lisp" "Write a symphony"))
(org-ql-expect ((not (local-tags)))
'("Test data" "Take over Mars" "Take over the moon" "Renew membership in supervillain club" "Learn universal sign language" "Recurring" "Sunrise/sunset" "Ideas" "Code" "Agenda examining" "Agenda censoring" "Auto grouping" "Auto categories" "Date" "Effort" "Misc" "let-plist" "Profiling")))
(org-ql-it "with a tag"
(org-ql-expect ((tags-local "world"))
'("Take over the world" "Skype with president of Antarctica"))
(org-ql-expect ((ltags "ambition"))
'("Take over the universe"))
(org-ql-expect ((not (tags-l "ambition")))
'("Test data" "Take over the world" "Skype with president of Antarctica" "Take over Mars" "Visit Mars" "Take over the moon" "Visit the moon" "Practice leaping tall buildings in a single bound" "Renew membership in supervillain club" "Learn universal sign language" "Order a pizza" "Get haircut" "Internet" "Spaceship lease" "Fix flux capacitor" "Recurring" "/r/emacs" "Shop for groceries" "Sunrise/sunset" "Ideas" "Rewrite Emacs in Common Lisp" "Write a symphony" "Code" "Agenda examining" "Agenda censoring" "Auto grouping" "Auto categories" "Date" "Effort" "Misc" "let-plist" "Profiling")))
(org-ql-it "with 2 tags"
(org-ql-expect ((ltags "personal" "world"))
'("Take over the world" "Skype with president of Antarctica" "Practice leaping tall buildings in a single bound" "Get haircut"))
(org-ql-expect ((not (tags-local "personal" "world")))
'("Test data" "Take over the universe" "Take over Mars" "Visit Mars" "Take over the moon" "Visit the moon" "Renew membership in supervillain club" "Learn universal sign language" "Order a pizza" "Internet" "Spaceship lease" "Fix flux capacitor" "Recurring" "/r/emacs" "Shop for groceries" "Sunrise/sunset" "Ideas" "Rewrite Emacs in Common Lisp" "Write a symphony" "Code" "Agenda examining" "Agenda censoring" "Auto grouping" "Auto categories" "Date" "Effort" "Misc" "let-plist" "Profiling"))))
(describe "(ts)"
(describe "active"