Merge branch 'maint'
This commit is contained in:
Nicolas Goaziou
commit
d79e80fc4a
317
lisp/org.el
317
lisp/org.el
|
|
@ -12484,168 +12484,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))
|
||||
(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")
|
||||
(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)
|
||||
(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))))
|
||||
(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))))
|
||||
;; 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.
|
||||
|
|
|
|||
Loading…
Reference in New Issue