From 2e241a934947f180e3cff6b6dec852f3c0cd7646 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/4] org: Grouptags not unique and can contain regexp * lisp/org.el (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-tag-alist) : New symbols for grouptags when the tags in the group don't have to be distinct on a heading. 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 [ ]. 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 : sub1 sub2 ] Grouptags also are not filtered when setting up tags. This means they can exist multiple times in org-tag-alist list. it 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 (org--setup-process-tags): Adaption for the added syntax for non-distinct grouptags. * lisp/org.el (org-fast-tag-selection): Add support for the added, non-unique, grouptag-syntax. --- lisp/org.el | 148 ++++++++++++++++++++++++++++++++++++++++++------------------ 1 file changed, 105 insertions(+), 43 deletions(-) diff --git a/lisp/org.el b/lisp/org.el index d05a7b8..8d47173 100755 --- a/lisp/org.el +++ b/lisp/org.el @@ -3482,11 +3482,17 @@ See the manual for details." (list :tag "Start radio group" (const :startgroup) (option (string :tag "Group description"))) + (list :tag "Start tag group, non distinct" + (const :startgrouptag) + (option (string :tag "Group description"))) (list :tag "Group tags delimiter" (const :grouptags)) (list :tag "End radio group" (const :endgroup) (option (string :tag "Group description"))) + (list :tag "End tag group, non distinct" + (const :endgrouptag) + (option (string :tag "Group description"))) (const :tag "New line" (:newline))))) (defcustom org-tag-persistent-alist nil @@ -5216,6 +5222,8 @@ FILETAGS is a list of tags, as strings." (case (car tag) (:startgroup "{") (:endgroup "}") + (:startgrouptag "[") + (:endgrouptag "]") (:grouptags ":") (:newline "\\n") (otherwise (concat (car tag) @@ -5236,12 +5244,20 @@ FILETAGS is a list of tags, as strings." ((equal e "}") (push '(:endgroup) org-tag-alist) (setq group-flag nil)) + ((equal e "[") + (push '(:startgrouptag) org-tag-alist) + (when (equal (nth 1 tags) ":") (setq group-flag t))) + ((equal e "]") + (push '(:endgrouptag) 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))))) @@ -5249,7 +5265,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))) @@ -14548,32 +14565,68 @@ 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) - ;; @ and _ are allowed as word-components in tags + (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) + (incf count) + (push (match-string 0 return-match) regexps-in-match) + (setq return-match (replace-match (format "<%d>" 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 (equal "{" (substring x 0 1)) + (equal "}" (substring x -1)) + 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 (equal "{" (substring x 0 1))) + (not (equal "}" (substring x -1))) + 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 (format "<%d>" count) + (pop regexps-in-match) + return-match t t)) + (decf 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))) @@ -15033,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 @@ -15066,24 +15119,33 @@ Returns the new tags string, or nil to not change the current settings." (setq tbl fulltable char ?a cnt 0) (while (setq e (pop tbl)) (cond - ((equal (car e) :startgroup) + ((eq (car e) :startgroup) (push '() groups) (setq ingroup t) - (when (not (= cnt 0)) + (unless (zerop cnt) (setq cnt 0) (insert "\n")) (insert (if (cdr e) (format "%s: " (cdr e)) "") "{ ")) - ((equal (car e) :endgroup) + ((eq (car e) :endgroup) (setq ingroup nil cnt 0) (insert "}" (if (cdr e) (format " (%s) " (cdr e)) "") "\n")) + ((eq (car e) :startgrouptag) + (setq intaggroup t) + (unless (zerop cnt) + (setq cnt 0) + (insert "\n")) + (insert "[ ")) + ((eq (car e) :endgrouptag) + (setq intaggroup nil cnt 0) + (insert "]\n")) ((equal e '(:newline)) - (when (not (= cnt 0)) + (unless (zerop cnt) (setq cnt 0) (insert "\n") (setq e (car tbl)) (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) @@ -15097,27 +15159,27 @@ Returns the new tags string, or nil to not change the current settings." (setq char (1+ char))) (setq c2 c1)) (setq c (or c2 char))) - (if ingroup (push tg (car groups))) + (when ingroup (push tg (car groups))) (setq tg (org-add-props tg nil 'face (cond ((not (assoc tg table)) (org-get-todo-face tg)) ((member tg current) c-face) ((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 " ")) + (when (equal (caar tbl) :grouptags) + (org-add-props tg nil 'face 'org-tag-group)) + (when (and (zerop cnt) (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) + (when (= (incf cnt) ncol) (insert "\n") - (if ingroup (insert " ")) + (when (or ingroup intaggroup) (insert " ")) (setq cnt 0))))) (setq ntable (nreverse ntable)) (insert "\n") (goto-char (point-min)) - (if (not expert) (org-fit-window-to-buffer)) + (unless expert (org-fit-window-to-buffer)) (setq rtn (catch 'exit (while t @@ -15147,7 +15209,7 @@ Returns the new tags string, or nil to not change the current settings." (setq quit-flag t)) ((= c ?\ ) (setq current nil) - (if exit-after-next (setq exit-after-next 'now))) + (when exit-after-next (setq exit-after-next 'now))) ((= c ?\t) (condition-case nil (setq tg (org-icompleting-read @@ -15161,28 +15223,28 @@ Returns the new tags string, or nil to not change the current settings." (if (member tg current) (setq current (delete tg current)) (push tg current))) - (if exit-after-next (setq exit-after-next 'now))) + (when exit-after-next (setq exit-after-next 'now))) ((setq e (rassoc c todo-table) tg (car e)) (with-current-buffer buf (save-excursion (org-todo tg))) - (if exit-after-next (setq exit-after-next 'now))) + (when exit-after-next (setq exit-after-next 'now))) ((setq e (rassoc c ntable) tg (car e)) (if (member tg current) (setq current (delete tg current)) (loop for g in groups do - (if (member tg g) - (mapc (lambda (x) - (setq current (delete x current))) - g))) + (when (member tg g) + (mapc (lambda (x) + (setq current (delete x current))) + g))) (push tg current)) - (if exit-after-next (setq exit-after-next 'now)))) + (when exit-after-next (setq exit-after-next 'now)))) ;; Create a sorted list (setq current (sort current (lambda (a b) (assoc b (cdr (memq (assoc a ntable) ntable)))))) - (if (eq exit-after-next 'now) (throw 'exit t)) + (when (eq exit-after-next 'now) (throw 'exit t)) (goto-char (point-min)) (beginning-of-line 2) (delete-region (point) (point-at-eol)) -- 1.9.1