Merge f300d04ec5 into 4b8330a683

org-ql.el

@@ -123,8 +123,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
+values are a list of four lists, namely inherited tags, local tags,
-strings.")
+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.
@@ -575,7 +583,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.
@@ -617,7 +625,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)
@@ -632,6 +676,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
@@ -2013,6 +2113,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."
@@ -2022,6 +2142,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."
@@ -2078,6 +2206,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."

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

tests/test-org-ql.el

@@ -1530,7 +1530,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)"
 
@@ -1561,7 +1587,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)"
 
@@ -1591,7 +1643,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&)"
 
@@ -1634,6 +1712,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"