From db680619c0bee593d6f15bdd96862bbf817cd2a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Gustav=20Wikstr=C3=B6m?= Date: Sat, 24 Jan 2015 02:47:26 +0100 Subject: [PATCH 1/3] org: Grouptags not unique and can contain regexp * lisp/org.el (org--setup-process-tags): (org-fast-tag-selection): Grouptags had to previously be defined with { }. This syntax is already used for exclusive tags and Grouptags need their own, non-exclusive syntax. This behaviour is achieved with [ ] instead. Note: { } can still be used also for Grouptags but then only one of the given tags can be used on the headline at the same time. Example: [ group : include1 included2 ] * lisp/org.el (org--setup-process-tags): (org-tags-expand): Grouptags can have regular expressions as "sub-tags". The regular expressions in the group must be marked up within { }. Example use: : #+TAGS: [ Project : {P@.+} ] Searching for the tag Project will now list all tags also including regular expression matches for P@.+. Good for example if tags for a certain project is tagged with a common project-identifier, i.e. P@2014_OrgTags. * lisp/org.el (org--setup-process-tags): Grouptags are not filtered when setting up tags. This means they can exist multiple times in org-tag-alist list. Will be usable if nesting of grouptags is ever to become reality. There is a slightly annoying side-effect when setting tags in that a tag which is both a part of a grouptag and a grouptag of it's own will get multiple key-choices in the selection-UI. --- lisp/org.el | 99 ++++++++++++++++++++++++++++++++++++++++++++++--------------- 1 file changed, 75 insertions(+), 24 deletions(-) diff --git a/lisp/org.el b/lisp/org.el index 3107e70..6bb8edf 100755 --- a/lisp/org.el +++ b/lisp/org.el @@ -5219,6 +5219,8 @@ FILETAGS is a list of tags, as strings." (case (car tag) (:startgroup "{") (:endgroup "}") + (:startgrouptags "[") + (:endgrouptags "]") (:grouptags ":") (:newline "\\n") (otherwise (concat (car tag) @@ -5239,12 +5241,20 @@ FILETAGS is a list of tags, as strings." ((equal e "}") (push '(:endgroup) org-tag-alist) (setq group-flag nil)) + ((equal e "[") + (push '(:startgrouptags) org-tag-alist) + (when (equal (nth 1 tags) ":") (setq group-flag t))) + ((equal e "]") + (push '(:endgrouptags) org-tag-alist) + (setq group-flag nil)) ((equal e ":") (push '(:grouptags) org-tag-alist) (setq group-flag 'append)) ((equal e "\\n") (push '(:newline) org-tag-alist)) ((string-match - (org-re "\\`\\([[:alnum:]_@#%]+\\)\\(?:(\\(.\\))\\)?\\'") e) + (org-re (concat "\\`\\([[:alnum:]_@#%]+" + "\\|{.+}\\)" ; regular expression + "\\(?:(\\(.\\))\\)?\\'")) e) (let ((tag (match-string 1 e)) (key (and (match-beginning 2) (string-to-char (match-string 2 e))))) @@ -5252,7 +5262,8 @@ FILETAGS is a list of tags, as strings." (setcar org-tag-groups-alist (append (car org-tag-groups-alist) (list tag)))) (group-flag (push (list tag) org-tag-groups-alist))) - (unless (assoc tag org-tag-alist) + ;; Push all tags in groups, no matter if they already exist. + (unless (and (not group-flag) (assoc tag org-tag-alist)) (push (cons tag key) org-tag-alist)))))))) (setq org-tag-alist (nreverse org-tag-alist))) @@ -14559,32 +14570,63 @@ When DOWNCASE is non-nil, expand downcased TAGS." (if org-group-tags (let* ((case-fold-search t) (stable org-mode-syntax-table) - (tal (or org-tag-groups-alist-for-agenda - org-tag-groups-alist)) - (tal (if downcased - (mapcar (lambda(tg) (mapcar 'downcase tg)) tal) tal)) - (tml (mapcar 'car tal)) - (rtnmatch match) rpl) + (taggroups (or org-tag-groups-alist-for-agenda org-tag-groups-alist)) + (taggroups (if downcased (mapcar (lambda(tg) (mapcar 'downcase tg)) taggroups) taggroups)) + (taggroups-keys (mapcar 'car taggroups)) + (return-match (if downcased (downcase match) match)) + (count 0) + regexps-in-match tags-in-group regexp-in-group regexp-in-group-escaped) ;; @ and _ are allowed as word-components in tags (modify-syntax-entry ?@ "w" stable) (modify-syntax-entry ?_ "w" stable) - (while (and tml + ;; Temporarily replace regexp-expressions in the match-expression + (while (string-match "{.+?}" return-match) + (setq count (1+ count)) + (setq regexps-in-match (cons (match-string 0 return-match) regexps-in-match)) + (setq return-match (replace-match (concat "<" (number-to-string count) ">") t nil return-match))) + (while (and taggroups-keys (with-syntax-table stable (string-match (concat "\\(?1:[+-]?\\)\\(?2:\\<" - (regexp-opt tml) "\\>\\)") rtnmatch))) - (let* ((dir (match-string 1 rtnmatch)) - (tag (match-string 2 rtnmatch)) + (regexp-opt taggroups-keys) "\\>\\)") return-match))) + (let* ((dir (match-string 1 return-match)) + (tag (match-string 2 return-match)) (tag (if downcased (downcase tag) tag))) - (setq tml (delete tag tml)) - (when (not (get-text-property 0 'grouptag (match-string 2 rtnmatch))) - (setq rpl (append (org-uniquify rpl) (assoc tag tal))) - (setq rpl (concat dir "{\\<" (regexp-opt rpl) "\\>}")) - (if (stringp rpl) (org-add-props rpl '(grouptag t))) - (setq rtnmatch (replace-match rpl t t rtnmatch))))) + (when (not (get-text-property 0 'grouptag (match-string 2 return-match))) + (setq tags-in-group (assoc tag taggroups)) + ; Filter tag-regexps from tags + (setq regexp-in-group-escaped (delq nil (mapcar (lambda (x) + (if (stringp x) + (and (string-prefix-p "{" x) + (string-suffix-p "}" x) + x) + x)) tags-in-group)) + regexp-in-group (mapcar (lambda (x) (substring x 1 -1)) regexp-in-group-escaped) + tags-in-group (delq nil (mapcar (lambda (x) + (if (stringp x) + (and (not (string-prefix-p "{" x)) + (not (string-suffix-p "}" x)) + x) + x)) tags-in-group))) + ; If single-as-list, do no more in the while-loop... + (if (not single-as-list) + (progn + (if regexp-in-group + (setq regexp-in-group (concat "\\|" (mapconcat 'identity regexp-in-group "\\|")))) + (setq tags-in-group (concat dir "{\\<" (regexp-opt tags-in-group) regexp-in-group "\\>}")) + (if (stringp tags-in-group) (org-add-props tags-in-group '(grouptag t))) + (setq return-match (replace-match tags-in-group t t return-match))) + (setq tags-in-group (append regexp-in-group-escaped tags-in-group)))) + (setq taggroups-keys (delete tag taggroups-keys)))) + ;; Add the regular expressions back into the match-expression again + (while regexps-in-match + (setq return-match (replace-regexp-in-string (concat "<" (number-to-string count) ">") + (pop regexps-in-match) + return-match t t)) + (setq count (1- count))) (if single-as-list - (or (reverse rpl) (list rtnmatch)) - rtnmatch)) + (if tags-in-group tags-in-group (list return-match)) + return-match)) (if single-as-list (list (if downcased (downcase match) match)) match))) @@ -15044,7 +15086,7 @@ Returns the new tags string, or nil to not change the current settings." ov-start ov-end ov-prefix (exit-after-next org-fast-tag-selection-single-key) (done-keywords org-done-keywords) - groups ingroup) + groups ingroup intaggroup) (save-excursion (beginning-of-line 1) (if (looking-at @@ -15086,6 +15128,15 @@ Returns the new tags string, or nil to not change the current settings." ((equal (car e) :endgroup) (setq ingroup nil cnt 0) (insert "}" (if (cdr e) (format " (%s) " (cdr e)) "") "\n")) + ((equal (car e) :startgrouptags) + (setq intaggroup t) + (when (not (= cnt 0)) + (setq cnt 0) + (insert "\n")) + (insert "[ ")) + ((equal (car e) :endgrouptags) + (setq intaggroup nil cnt 0) + (insert "]\n")) ((equal e '(:newline)) (when (not (= cnt 0)) (setq cnt 0) @@ -15094,7 +15145,7 @@ Returns the new tags string, or nil to not change the current settings." (while (equal (car tbl) '(:newline)) (insert "\n") (setq tbl (cdr tbl))))) - ((equal e '(:grouptags)) nil) + ((equal e '(:grouptags)) (insert " : ")) (t (setq tg (copy-sequence (car e)) c2 nil) (if (cdr e) @@ -15117,13 +15168,13 @@ Returns the new tags string, or nil to not change the current settings." ((member tg inherited) i-face)))) (if (equal (caar tbl) :grouptags) (org-add-props tg nil 'face 'org-tag-group)) - (if (and (= cnt 0) (not ingroup)) (insert " ")) + (if (and (= cnt 0) (not ingroup) (not intaggroup)) (insert " ")) (insert "[" c "] " tg (make-string (- fwidth 4 (length tg)) ?\ )) (push (cons tg c) ntable) (when (= (setq cnt (1+ cnt)) ncol) (insert "\n") - (if ingroup (insert " ")) + (if (or ingroup intaggroup) (insert " ")) (setq cnt 0))))) (setq ntable (nreverse ntable)) (insert "\n") -- 1.9.1