|
@@ -14564,168 +14564,169 @@ Returns the new tags string, or nil to not change the current settings."
|
|
|
" "
|
|
|
(make-string (- org-tags-column (current-column)) ?\ ))))))
|
|
|
(move-overlay org-tags-overlay ov-start ov-end)
|
|
|
- (save-window-excursion
|
|
|
- (if expert
|
|
|
- (set-buffer (get-buffer-create " *Org tags*"))
|
|
|
- (delete-other-windows)
|
|
|
- (set-window-buffer (split-window-vertically) (get-buffer-create " *Org tags*"))
|
|
|
- (org-switch-to-buffer-other-window " *Org tags*"))
|
|
|
- (erase-buffer)
|
|
|
- (setq-local org-done-keywords done-keywords)
|
|
|
- (org-fast-tag-insert "Inherited" inherited i-face "\n")
|
|
|
- (org-fast-tag-insert "Current" current c-face "\n\n")
|
|
|
- (org-fast-tag-show-exit exit-after-next)
|
|
|
- (org-set-current-tags-overlay current ov-prefix)
|
|
|
- (setq tbl fulltable char ?a cnt 0)
|
|
|
- (while (setq e (pop tbl))
|
|
|
- (cond
|
|
|
- ((eq (car e) :startgroup)
|
|
|
- (push '() groups) (setq ingroup t)
|
|
|
- (unless (zerop cnt)
|
|
|
- (setq cnt 0)
|
|
|
- (insert "\n"))
|
|
|
- (insert (if (cdr e) (format "%s: " (cdr e)) "") "{ "))
|
|
|
- ((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))
|
|
|
- (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)) (insert " : "))
|
|
|
- (t
|
|
|
- (setq tg (copy-sequence (car e)) c2 nil)
|
|
|
- (if (cdr e)
|
|
|
- (setq c (cdr e))
|
|
|
- ;; automatically assign a character.
|
|
|
- (setq c1 (string-to-char
|
|
|
- (downcase (substring
|
|
|
- tg (if (= (string-to-char tg) ?@) 1 0)))))
|
|
|
- (if (or (rassoc c1 ntable) (rassoc c1 table))
|
|
|
- (while (or (rassoc char ntable) (rassoc char table))
|
|
|
- (setq char (1+ char)))
|
|
|
- (setq c2 c1))
|
|
|
- (setq c (or c2 char)))
|
|
|
- (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))))
|
|
|
- (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 (= (cl-incf cnt) ncol)
|
|
|
- (unless (memq (caar tbl) '(:endgroup :endgrouptag))
|
|
|
+ (save-excursion
|
|
|
+ (save-window-excursion
|
|
|
+ (if expert
|
|
|
+ (set-buffer (get-buffer-create " *Org tags*"))
|
|
|
+ (delete-other-windows)
|
|
|
+ (set-window-buffer (split-window-vertically) (get-buffer-create " *Org tags*"))
|
|
|
+ (org-switch-to-buffer-other-window " *Org tags*"))
|
|
|
+ (erase-buffer)
|
|
|
+ (setq-local org-done-keywords done-keywords)
|
|
|
+ (org-fast-tag-insert "Inherited" inherited i-face "\n")
|
|
|
+ (org-fast-tag-insert "Current" current c-face "\n\n")
|
|
|
+ (org-fast-tag-show-exit exit-after-next)
|
|
|
+ (org-set-current-tags-overlay current ov-prefix)
|
|
|
+ (setq tbl fulltable char ?a cnt 0)
|
|
|
+ (while (setq e (pop tbl))
|
|
|
+ (cond
|
|
|
+ ((eq (car e) :startgroup)
|
|
|
+ (push '() groups) (setq ingroup t)
|
|
|
+ (unless (zerop cnt)
|
|
|
+ (setq cnt 0)
|
|
|
+ (insert "\n"))
|
|
|
+ (insert (if (cdr e) (format "%s: " (cdr e)) "") "{ "))
|
|
|
+ ((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))
|
|
|
+ (unless (zerop cnt)
|
|
|
+ (setq cnt 0)
|
|
|
(insert "\n")
|
|
|
- (when (or ingroup intaggroup) (insert " ")))
|
|
|
- (setq cnt 0)))))
|
|
|
- (setq ntable (nreverse ntable))
|
|
|
- (insert "\n")
|
|
|
- (goto-char (point-min))
|
|
|
- (unless expert (org-fit-window-to-buffer))
|
|
|
- (setq rtn
|
|
|
- (catch 'exit
|
|
|
- (while t
|
|
|
- (message "[a-z..]:toggle [SPC]:clear [RET]:accept [TAB]:edit [!] %sgroups%s"
|
|
|
- (if (not groups) "no " "")
|
|
|
- (if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi")))
|
|
|
- (setq c (let ((inhibit-quit t)) (read-char-exclusive)))
|
|
|
- (setq org-last-tag-selection-key c)
|
|
|
- (cond
|
|
|
- ((= c ?\r) (throw 'exit t))
|
|
|
- ((= c ?!)
|
|
|
- (setq groups (not groups))
|
|
|
- (goto-char (point-min))
|
|
|
- (while (re-search-forward "[{}]" nil t) (replace-match " ")))
|
|
|
- ((= c ?\C-c)
|
|
|
- (if (not expert)
|
|
|
- (org-fast-tag-show-exit
|
|
|
- (setq exit-after-next (not exit-after-next)))
|
|
|
- (setq expert nil)
|
|
|
- (delete-other-windows)
|
|
|
- (set-window-buffer (split-window-vertically) " *Org tags*")
|
|
|
- (org-switch-to-buffer-other-window " *Org tags*")
|
|
|
- (org-fit-window-to-buffer)))
|
|
|
- ((or (= c ?\C-g)
|
|
|
- (and (= c ?q) (not (rassoc c ntable))))
|
|
|
- (delete-overlay org-tags-overlay)
|
|
|
- (setq quit-flag t))
|
|
|
- ((= c ?\ )
|
|
|
- (setq current nil)
|
|
|
- (when exit-after-next (setq exit-after-next 'now)))
|
|
|
- ((= c ?\t)
|
|
|
- (condition-case nil
|
|
|
- (setq tg (completing-read
|
|
|
- "Tag: "
|
|
|
- (or buffer-tags
|
|
|
- (with-current-buffer buf
|
|
|
- (setq buffer-tags
|
|
|
- (org-get-buffer-tags))))))
|
|
|
- (quit (setq tg "")))
|
|
|
- (when (string-match "\\S-" tg)
|
|
|
- (cl-pushnew (list tg) buffer-tags :test #'equal)
|
|
|
+ (setq e (car tbl))
|
|
|
+ (while (equal (car tbl) '(:newline))
|
|
|
+ (insert "\n")
|
|
|
+ (setq tbl (cdr tbl)))))
|
|
|
+ ((equal e '(:grouptags)) (insert " : "))
|
|
|
+ (t
|
|
|
+ (setq tg (copy-sequence (car e)) c2 nil)
|
|
|
+ (if (cdr e)
|
|
|
+ (setq c (cdr e))
|
|
|
+ ;; automatically assign a character.
|
|
|
+ (setq c1 (string-to-char
|
|
|
+ (downcase (substring
|
|
|
+ tg (if (= (string-to-char tg) ?@) 1 0)))))
|
|
|
+ (if (or (rassoc c1 ntable) (rassoc c1 table))
|
|
|
+ (while (or (rassoc char ntable) (rassoc char table))
|
|
|
+ (setq char (1+ char)))
|
|
|
+ (setq c2 c1))
|
|
|
+ (setq c (or c2 char)))
|
|
|
+ (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))))
|
|
|
+ (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 (= (cl-incf cnt) ncol)
|
|
|
+ (unless (memq (caar tbl) '(:endgroup :endgrouptag))
|
|
|
+ (insert "\n")
|
|
|
+ (when (or ingroup intaggroup) (insert " ")))
|
|
|
+ (setq cnt 0)))))
|
|
|
+ (setq ntable (nreverse ntable))
|
|
|
+ (insert "\n")
|
|
|
+ (goto-char (point-min))
|
|
|
+ (unless expert (org-fit-window-to-buffer))
|
|
|
+ (setq rtn
|
|
|
+ (catch 'exit
|
|
|
+ (while t
|
|
|
+ (message "[a-z..]:toggle [SPC]:clear [RET]:accept [TAB]:edit [!] %sgroups%s"
|
|
|
+ (if (not groups) "no " "")
|
|
|
+ (if expert " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi")))
|
|
|
+ (setq c (let ((inhibit-quit t)) (read-char-exclusive)))
|
|
|
+ (setq org-last-tag-selection-key c)
|
|
|
+ (cond
|
|
|
+ ((= c ?\r) (throw 'exit t))
|
|
|
+ ((= c ?!)
|
|
|
+ (setq groups (not groups))
|
|
|
+ (goto-char (point-min))
|
|
|
+ (while (re-search-forward "[{}]" nil t) (replace-match " ")))
|
|
|
+ ((= c ?\C-c)
|
|
|
+ (if (not expert)
|
|
|
+ (org-fast-tag-show-exit
|
|
|
+ (setq exit-after-next (not exit-after-next)))
|
|
|
+ (setq expert nil)
|
|
|
+ (delete-other-windows)
|
|
|
+ (set-window-buffer (split-window-vertically) " *Org tags*")
|
|
|
+ (org-switch-to-buffer-other-window " *Org tags*")
|
|
|
+ (org-fit-window-to-buffer)))
|
|
|
+ ((or (= c ?\C-g)
|
|
|
+ (and (= c ?q) (not (rassoc c ntable))))
|
|
|
+ (delete-overlay org-tags-overlay)
|
|
|
+ (setq quit-flag t))
|
|
|
+ ((= c ?\ )
|
|
|
+ (setq current nil)
|
|
|
+ (when exit-after-next (setq exit-after-next 'now)))
|
|
|
+ ((= c ?\t)
|
|
|
+ (condition-case nil
|
|
|
+ (setq tg (completing-read
|
|
|
+ "Tag: "
|
|
|
+ (or buffer-tags
|
|
|
+ (with-current-buffer buf
|
|
|
+ (setq buffer-tags
|
|
|
+ (org-get-buffer-tags))))))
|
|
|
+ (quit (setq tg "")))
|
|
|
+ (when (string-match "\\S-" tg)
|
|
|
+ (cl-pushnew (list tg) buffer-tags :test #'equal)
|
|
|
+ (if (member tg current)
|
|
|
+ (setq current (delete tg current))
|
|
|
+ (push tg current)))
|
|
|
+ (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)))
|
|
|
+ (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))
|
|
|
- (push tg current)))
|
|
|
- (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)))
|
|
|
- (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))
|
|
|
- (cl-loop for g in groups do
|
|
|
- (when (member tg g)
|
|
|
- (dolist (x g) (setq current (delete x current)))))
|
|
|
- (push tg current))
|
|
|
- (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))))))
|
|
|
- (when (eq exit-after-next 'now) (throw 'exit t))
|
|
|
- (goto-char (point-min))
|
|
|
- (beginning-of-line 2)
|
|
|
- (delete-region (point) (point-at-eol))
|
|
|
- (org-fast-tag-insert "Current" current c-face)
|
|
|
- (org-set-current-tags-overlay current ov-prefix)
|
|
|
- (let ((tag-re (concat "\\[.\\] \\(" org-tag-re "\\)")))
|
|
|
- (while (re-search-forward tag-re nil t)
|
|
|
- (let ((tag (match-string 1)))
|
|
|
- (add-text-properties
|
|
|
- (match-beginning 1) (match-end 1)
|
|
|
- (list 'face
|
|
|
- (cond
|
|
|
- ((member tag current) c-face)
|
|
|
- ((member tag inherited) i-face)
|
|
|
- (t (get-text-property (match-beginning 1) '
|
|
|
- face))))))))
|
|
|
- (goto-char (point-min)))))
|
|
|
- (delete-overlay org-tags-overlay)
|
|
|
- (if rtn
|
|
|
- (mapconcat 'identity current ":")
|
|
|
- nil))))
|
|
|
+ (cl-loop for g in groups do
|
|
|
+ (when (member tg g)
|
|
|
+ (dolist (x g) (setq current (delete x current)))))
|
|
|
+ (push tg current))
|
|
|
+ (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))))))
|
|
|
+ (when (eq exit-after-next 'now) (throw 'exit t))
|
|
|
+ (goto-char (point-min))
|
|
|
+ (beginning-of-line 2)
|
|
|
+ (delete-region (point) (point-at-eol))
|
|
|
+ (org-fast-tag-insert "Current" current c-face)
|
|
|
+ (org-set-current-tags-overlay current ov-prefix)
|
|
|
+ (let ((tag-re (concat "\\[.\\] \\(" org-tag-re "\\)")))
|
|
|
+ (while (re-search-forward tag-re nil t)
|
|
|
+ (let ((tag (match-string 1)))
|
|
|
+ (add-text-properties
|
|
|
+ (match-beginning 1) (match-end 1)
|
|
|
+ (list 'face
|
|
|
+ (cond
|
|
|
+ ((member tag current) c-face)
|
|
|
+ ((member tag inherited) i-face)
|
|
|
+ (t (get-text-property (match-beginning 1) '
|
|
|
+ face))))))))
|
|
|
+ (goto-char (point-min)))))
|
|
|
+ (delete-overlay org-tags-overlay)
|
|
|
+ (if rtn
|
|
|
+ (mapconcat 'identity current ":")
|
|
|
+ nil)))))
|
|
|
|
|
|
(defun org-make-tag-string (tags)
|
|
|
"Return string associated to TAGS.
|