diff --git a/org-ql.el b/org-ql.el index c0f548a5..3ec21f6a 100644 --- a/org-ql.el +++ b/org-ql.el @@ -115,8 +115,16 @@ hash table, keyed by arguments passed to "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.") +values are a list of four lists, namely inherited tags, local tags, +group tags an entry matches owing to local tags and +group tags an entry matches owing to inherited tags, +all as strings.") + +(defvar org-ql-tag-groups-cache (make-hash-table :weakness 'key) + "Per-buffer tag groups cache. +Keyed by buffer. Each value is a cons of the buffer's tag group hierarchy and +another hash table keyed on tags, whose values are the list group tags also +matched due to tag hierarchy, as strings.") (defvar org-ql-node-value-cache (make-hash-table :weakness 'key) "Per-buffer node cache. @@ -562,7 +570,7 @@ readable file, `find-file-noselect' it into a buffer." (defun org-ql--tags-at (position) ;; FIXME: This function actually assumes that point is already at POSITION. "Return tags for POSITION in current buffer. -Returns cons (INHERITED-TAGS . LOCAL-TAGS)." +Returns cons (INHERITED-TAGS LOCAL-TAGS INHERITED-GROUP-TAGS LOCAL-GROUP-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. @@ -604,7 +612,43 @@ Returns cons (INHERITED-TAGS . LOCAL-TAGS)." ;; Top-level heading: use file tags. org-file-tags))) 'org-ql-nil)) - (all-tags (list inherited-tags local-tags))) + (local-group-tags nil) + (inherited-group-tags nil) + all-tags) + ;; If group hierarchy is enabled and there are tag definitions, + ;; then compute sets of group tags implicitly matched by + ;; local and inherited tags. + (when (and org-group-tags org-current-tag-alist) + (let* ((buffer-tag-groups-cache (gethash (current-buffer) + org-ql-tag-groups-cache)) + tag-hierarchy + matching-group-tags-cache) + ;; If buffer has no cache yet or + ;; if it has been modified since the last time accessing the cache, + ;; we need to reset the cache. + (unless (and buffer-tag-groups-cache buffer-unmodified-p) + (setq buffer-tag-groups-cache + (cons (org-tag-alist-to-groups org-current-tag-alist) + (make-hash-table :test 'equal))) + (puthash (current-buffer) + buffer-tag-groups-cache + org-ql-tag-groups-cache)) + (setq tag-hierarchy (car buffer-tag-groups-cache) + matching-group-tags-cache (cdr buffer-tag-groups-cache)) + ;; If there are tag groups defined, + ;; then get the group tags implicitly matched along with local and inherited ones. + (when tag-hierarchy + (unless (eq local-tags 'org-ql-nil) + (setq local-group-tags + (org-ql--expand-tag-hierarchy local-tags + tag-hierarchy + matching-group-tags-cache))) + (unless (eq inherited-tags 'org-ql-nil) + (setq inherited-group-tags + (org-ql--expand-tag-hierarchy inherited-tags + tag-hierarchy + matching-group-tags-cache)))))) + (setq all-tags (list inherited-tags local-tags inherited-group-tags local-group-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) @@ -619,6 +663,62 @@ Returns cons (INHERITED-TAGS . LOCAL-TAGS)." org-ql-tags-cache)) (puthash position all-tags tags-cache)))) +(defun org-ql--expand-tag-hierarchy (tags &optional groups cache exclude) + "Return group tags of groups that TAGS belong to. + +Particularly, this function recursively searches for groups in GROUPS that +each tag belongs to and includes the corresponding group tags to the result, +unless explicitly excluded. + +TAGS should be a list of tags (i.e., strings). +If GROUPS is non-nil, then it must be a list of tag group definitions of +the form (tag member1 member2 ...). Otherwise, it defaults to the buffer's +current tag hierarchy. + +If non-nil, EXCLUDE should be a list of group tags that will neither +be included to the results nor futher expanded. + +If CACHE is non-nil, it should be a hash table which maps tags to +readily computed group tags." + (let ((groups (or groups (org-tag-alist-to-groups org-current-tag-alist))) + (exclude (-uniq (append tags exclude))) + result) + ;; Iterate over the tags and check if they belong to any of the groups. + (dolist (tag tags) + ;; Check if the groups this tag belongs to have already been cached. + ;; If so, add them to the results. Otherwise, compute and cache them. + (let ((cached-matches (gethash tag cache 'org-ql-nil))) + (if (eq cached-matches 'org-ql-nil) + (let (matching-group-tags + matching-group-tags-expansion) + (pcase-dolist (`(,group-tag . ,group-members) groups) + ;; Check if one of the members in the group matches this tag. + ;; Notice that each member may be a plain string or + ;; a regexp pattern (enclosed between curly brackets). + (when (and (not (member group-tag exclude)) + (--some (if (string-match-p "^[{].+[}]$" it) + ;; If pattern (it) is a regexp, remove the brackets and + ;; make sure that it either matches the whole tag or not. + (string-match-p (concat "^" (substring it 1 -1) "$") tag) + ;; Check if member (it) is identical to tag. + (string= it tag)) + group-members)) + (push group-tag matching-group-tags))) + ;; If matching group tags have been found, expand them as well. + (when matching-group-tags + (setq matching-group-tags-expansion + (append matching-group-tags + (org-ql--expand-tag-hierarchy matching-group-tags groups cache exclude)))) + ;; If a cache has been provided, cache the result. + ;; Then add it to the results. + (when cache + (puthash tag matching-group-tags-expansion cache)) + (setq result (-uniq (append matching-group-tags-expansion result)) + exclude (-uniq (append matching-group-tags-expansion exclude)))) + (setq result (-uniq (append cached-matches result)) + exclude (-uniq (append cached-matches exclude)))))) + result)) + (defun org-ql--outline-path () "Return outline path for heading at point." (save-excursion @@ -1972,6 +2072,26 @@ Tests both inherited and local tags." (when (tags-p local) (seq-intersection tags local)))))))) +(org-ql-defpred (group-tags) (&rest tags) + "Return non-nil if current heading has one or more of TAGS (a list of strings). +Tests both inherited and local tags as well as group tags by expanding hierarchy." + ;; MAYBE: -all versions for inherited and local. + :body (cl-macrolet ((tags-p (tags) + `(and ,tags + (not (eq 'org-ql-nil ,tags))))) + (-let* (((inherited local inherited-groups local-groups) (org-ql--tags-at (point)))) + (cl-typecase tags + (null (or (tags-p inherited) + (tags-p local))) + (otherwise (or (when (tags-p inherited) + (seq-intersection tags (if (tags-p inherited-groups) + (append inherited inherited-groups) + inherited))) + (when (tags-p local) + (seq-intersection tags (if (tags-p local-groups) + (append local local-groups) + local))))))))) + (org-ql-defpred (tags-all tags&) (&rest tags) "Return non-nil if current heading has all of TAGS (a list of strings). Tests both inherited and local tags." @@ -1981,6 +2101,14 @@ Tests both inherited and local tags." `(and ,@(--map `(tags ,it) tags)))) :body (apply #'org-ql--predicate-tags tags)) +(org-ql-defpred (group-tags-all group-tags&) (&rest tags) + "Return non-nil if current heading has all of TAGS (a list of strings). +Tests both inherited and local tags as well as group tags by expanding hierarchy." + ;; MAYBE: -all versions for inherited and local. + :normalizers ((`(,predicate-names) `(tags)) + (`(,predicate-names . ,tags) `(and ,@(--map `(group-tags ,it) tags)))) + :body (apply #'org-ql--predicate-group-tags tags)) + (org-ql-defpred (tags-inherited inherited-tags tags-i itags) (&rest tags) "Return non-nil if current heading's inherited tags include any of TAGS. If TAGS is nil, return non-nil if heading has any inherited tags." @@ -2037,6 +2165,31 @@ Tests both inherited and local tags." thereis (cl-loop for regexp in regexps thereis (string-match regexp tag)))))))))) +(org-ql-defpred (group-tags-regexp group-tags*) (&rest regexps) + "Return non-nil if current heading has tags matching one or more of REGEXPS. +Tests both inherited and local tags as well as group tags by expanding hierarchy." + :normalizers ((`(,predicate-names . ,regexps) + `(group-tags-regexp ,@regexps))) + :body (cl-macrolet ((tags-p (tags) + `(and ,tags + (not (eq 'org-ql-nil ,tags))))) + (-let* (((inherited local inherited-groups local-groups) (org-ql--tags-at (point)))) + (cl-typecase regexps + (null (or (tags-p inherited) + (tags-p local))) + (otherwise (or (when (tags-p inherited) + (cl-loop for tag in (if (tags-p inherited-groups) + (append inherited inherited-groups) + inherited) + thereis (cl-loop for regexp in regexps + thereis (string-match regexp tag)))) + (when (tags-p local) + (cl-loop for tag in (if (tags-p local-groups) + (append local local-groups) + local) + thereis (cl-loop for regexp in regexps + thereis (string-match regexp tag)))))))))) + (org-ql-defpred todo (&rest keywords) "Return non-nil if current heading is a TODO item. With KEYWORDS, return non-nil if its keyword is one of KEYWORDS." diff --git a/tests/data-tags-with-hierarchy.org b/tests/data-tags-with-hierarchy.org new file mode 100644 index 00000000..e52b437c --- /dev/null +++ b/tests/data-tags-with-hierarchy.org @@ -0,0 +1,21 @@ +# This file is currently used to test org-file-tags with tag hierarchies. + +#+FILETAGS: :groceries: +#+TAGS: [ food : produce meat ] +#+TAGS: [ produce : fruit vegetable ] +#+TAGS: [ meat : poultry beef fish ] + +* Meat +** Poultry :poultry: +*** Chicken :like: +*** Duck +** Beef :beef: +** Fish :fish: +*** Tuna +*** Salmon :like: +* Fruit :fruit: +** Blueberry +** Strawberry +* Vegetable :vegetable: +** Broccoli +** Potato diff --git a/tests/test-org-ql.el b/tests/test-org-ql.el index 5f9463f1..4bc51dd6 100644 --- a/tests/test-org-ql.el +++ b/tests/test-org-ql.el @@ -1487,7 +1487,33 @@ with keyword arg NOW in PLIST." :buffer (org-ql-test-data-buffer "data-file-tags.org")) (org-ql-expect ('(tags "fruit")) '("Fruit" "Blueberry" "Strawberry") - :buffer (org-ql-test-data-buffer "data-file-tags.org")))) + :buffer (org-ql-test-data-buffer "data-file-tags.org"))) + + (org-ql-it "with tag hierarchy" + (org-ql-expect ('(tags "groceries")) + '("Meat" "Poultry" "Chicken" "Duck" "Beef" "Fish" "Tuna" "Salmon" "Fruit" "Blueberry" "Strawberry" "Vegetable" "Broccoli" "Potato") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags "food")) + nil + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags "meat")) + nil + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags "fish")) + '("Fish" "Tuna" "Salmon") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags "beef")) + '("Beef") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags "produce")) + nil + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags "vegetable")) + '("Vegetable" "Broccoli" "Potato") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags "fruit")) + '("Fruit" "Blueberry" "Strawberry") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")))) (describe "(tags-inherited)" @@ -1518,7 +1544,33 @@ with keyword arg NOW in PLIST." :buffer (org-ql-test-data-buffer "data-file-tags.org")) (org-ql-expect ('(tags-inherited "fruit")) '("Blueberry" "Strawberry") - :buffer (org-ql-test-data-buffer "data-file-tags.org")))) + :buffer (org-ql-test-data-buffer "data-file-tags.org"))) + + (org-ql-it "with tag hierarchy" + (org-ql-expect ('(tags-inherited "groceries")) + '("Meat" "Poultry" "Chicken" "Duck" "Beef" "Fish" "Tuna" "Salmon" "Fruit" "Blueberry" "Strawberry" "Vegetable" "Broccoli" "Potato") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-inherited "food")) + nil + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-inherited "meat")) + nil + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-inherited "fish")) + '("Tuna" "Salmon") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-inherited "beef")) + nil + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-inherited "produce")) + nil + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-inherited "vegetable")) + '("Broccoli" "Potato") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-inherited "fruit")) + '("Blueberry" "Strawberry") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")))) (describe "(tags-local)" @@ -1548,7 +1600,33 @@ with keyword arg NOW in PLIST." :buffer (org-ql-test-data-buffer "data-file-tags.org")) (org-ql-expect ('(tags-local "fruit")) '("Fruit") - :buffer (org-ql-test-data-buffer "data-file-tags.org")))) + :buffer (org-ql-test-data-buffer "data-file-tags.org"))) + + (org-ql-it "with tag hierarchy" + (org-ql-expect ('(tags-local "groceries")) + nil + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-local "food")) + nil + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-local "meat")) + nil + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-local "fish")) + '("Fish") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-local "beef")) + '("Beef") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-local "produce")) + nil + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-local "vegetable")) + '("Vegetable") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(tags-local "fruit")) + '("Fruit") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")))) (describe "(tags-all), (tags&)" @@ -1591,6 +1669,60 @@ with keyword arg NOW in PLIST." '("Fruit" "Blueberry" "Strawberry") :buffer (org-ql-test-data-buffer "data-file-tags.org")))) + (describe "(group-tags)" + + (org-ql-it "with tag hierarchy" + (org-ql-expect ('(group-tags "groceries")) + '("Meat" "Poultry" "Chicken" "Duck" "Beef" "Fish" "Tuna" "Salmon" "Fruit" "Blueberry" "Strawberry" "Vegetable" "Broccoli" "Potato") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(group-tags "food")) + '("Poultry" "Chicken" "Duck" "Beef" "Fish" "Tuna" "Salmon" "Fruit" "Blueberry" "Strawberry" "Vegetable" "Broccoli" "Potato") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(group-tags "meat")) + '("Poultry" "Chicken" "Duck" "Beef" "Fish" "Tuna" "Salmon") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(group-tags "fish")) + '("Fish" "Tuna" "Salmon") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(group-tags "beef")) + '("Beef") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(group-tags "produce")) + '("Fruit" "Blueberry" "Strawberry" "Vegetable" "Broccoli" "Potato") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(group-tags "vegetable")) + '("Vegetable" "Broccoli" "Potato") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(group-tags "fruit")) + '("Fruit" "Blueberry" "Strawberry") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")))) + + (describe "(group-tags-all), (group-tags&)" + + (org-ql-it "with tag hierarchy" + (org-ql-expect ('(group-tags-all "groceries" "like")) + '("Chicken" "Salmon") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(group-tags-all "poultry" "like")) + '("Chicken") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(group-tags-all "fish" "like")) + '("Salmon") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(group-tags-all "vegetables" "like")) + nil + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")))) + + (describe "(group-tags-regexp), (group-tags*)" + + (org-ql-it "with tag hierarchy" + (org-ql-expect ('(group-tags-regexp ".*ke.*")) + '("Chicken" "Salmon") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")) + (org-ql-expect ('(group-tags-regexp ".*ea.*")) + '("Poultry" "Chicken" "Duck" "Beef" "Fish" "Tuna" "Salmon") + :buffer (org-ql-test-data-buffer "data-tags-with-hierarchy.org")))) + (describe "(ts)" (describe "active"