Improve Org tag selection
This commit is contained in:
parent
98f6339300
commit
23a2b808fd
GPG key ID:
6CB106C25E86A9F7
352
config.org
352
config.org
|
|
@ -3051,6 +3051,358 @@ I don't want to have to specify the =RESET_CHECK_BOXES= property for every TODO
|
|||
|
||||
** Bug Fixes and Tweaks
|
||||
|
||||
*** Improved Tag Selection
|
||||
|
||||
The facilities for selecting and adding tags do not play very nicely with complex tag hierarchies, especially fast tag selection. The main problems are:
|
||||
|
||||
- Fast tag selection interprets regex tags as actual tags
|
||||
- Fast tag selection can assign multiple keys to the same tag
|
||||
- Regular tag selection interprets special tag entries such as ~:startgroup~ as actual tags
|
||||
|
||||
To fix this, we'll need some liberal use of override advising.
|
||||
|
||||
#+begin_src emacs-lisp
|
||||
(defadvice! ~/org-assign-fast-keys (alist)
|
||||
:override #'org-assign-fast-keys
|
||||
(let (new e (alt ?0))
|
||||
(while (setq e (pop alist))
|
||||
(if (or (memq (car e) '(:newline :grouptags :endgroup :startgroup :startgrouptag :endgrouptag))
|
||||
(and (string-prefix-p "{" (car e)) (string-suffix-p "}" (car e)))
|
||||
(cdr e)) ;; Key already assigned.
|
||||
(push e new)
|
||||
(let ((clist (string-to-list (downcase (car e))))
|
||||
(used (append new alist)))
|
||||
(when (= (car clist) ?@)
|
||||
(pop clist))
|
||||
(while (and clist (rassoc (car clist) used))
|
||||
(pop clist))
|
||||
(unless clist
|
||||
(while (rassoc alt used)
|
||||
(cl-incf alt)))
|
||||
(push (cons (car e) (or (car clist) alt)) new))))
|
||||
(nreverse new)))
|
||||
|
||||
(defadvice! ~/org-fast-tag-selection (current-tags inherited-tags tag-table &optional todo-table)
|
||||
:override #'org-fast-tag-selection
|
||||
(let* (;; Combined alist of all the tags and todo keywords.
|
||||
(tag-alist (append tag-table todo-table))
|
||||
;; Max width occupied by a single tag record in the completion buffer.
|
||||
(field-width
|
||||
(+ 3 ; keep space for "[c]" binding.
|
||||
1 ; ensure that there is at least one space between adjacent tag fields.
|
||||
3 ; keep space for group tag " : " delimiter.
|
||||
;; The longest tag.
|
||||
(if (null tag-alist) 0
|
||||
(apply #'max
|
||||
(mapcar (lambda (x)
|
||||
(if (stringp (car x)) (string-width (car x))
|
||||
0))
|
||||
tag-alist)))))
|
||||
(origin-buffer (current-buffer))
|
||||
(expert-interface (eq org-fast-tag-selection-single-key 'expert))
|
||||
;; Tag completion table, for normal completion (<TAB>).
|
||||
(tab-tags nil)
|
||||
(inherited-face 'org-done)
|
||||
(current-face 'org-todo)
|
||||
;; Characters available for auto-assignment.
|
||||
(tag-binding-char-list org--fast-tag-selection-keys)
|
||||
(tag-binding-chars-left org-fast-tag-selection-maximum-tags)
|
||||
field-number ; current tag column in the completion buffer.
|
||||
tag-binding-spec ; Alist element.
|
||||
current-tag current-tag-char auto-tag-char
|
||||
tag-table-local ; table holding all the displayed tags together with auto-assigned bindings.
|
||||
input-char rtn
|
||||
ov-start ov-end ov-prefix
|
||||
(exit-after-next org-fast-tag-selection-single-key)
|
||||
(done-keywords org-done-keywords)
|
||||
groups ingroup intaggroup char-tags)
|
||||
;; Calculate the number of tags with explicit user bindings + tags in groups.
|
||||
;; These tags will be displayed unconditionally. Other tags will
|
||||
;; be displayed only when there are free bindings left according
|
||||
;; to `org-fast-tag-selection-maximum-tags'.
|
||||
(dolist (tag-binding-spec tag-alist)
|
||||
(pcase tag-binding-spec
|
||||
(`((or :startgroup :startgrouptag) . _)
|
||||
(setq ingroup t))
|
||||
(`((or :endgroup :endgrouptag) . _)
|
||||
(setq ingroup nil))
|
||||
((guard (cdr tag-binding-spec))
|
||||
(cl-decf tag-binding-chars-left))
|
||||
(`((or :newline :grouptags))) ; pass
|
||||
((guard ingroup)
|
||||
(cl-decf tag-binding-chars-left))))
|
||||
(setq ingroup nil) ; It t, it means malformed tag alist. Reset just in case.
|
||||
;; Move global `org-tags-overlay' overlay to current heading.
|
||||
;; Calls to `org-set-current-tags-overlay' will take care about
|
||||
;; updating the overlay text.
|
||||
;; FIXME: What if we are setting file tags?
|
||||
(save-excursion
|
||||
(forward-line 0)
|
||||
(if (looking-at org-tag-line-re)
|
||||
(setq ov-start (match-beginning 1)
|
||||
ov-end (match-end 1)
|
||||
ov-prefix "")
|
||||
(setq ov-start (1- (line-end-position))
|
||||
ov-end (1+ ov-start))
|
||||
(skip-chars-forward "^\n\r")
|
||||
(setq ov-prefix
|
||||
(concat
|
||||
(buffer-substring (1- (point)) (point))
|
||||
(if (> (current-column) org-tags-column)
|
||||
" "
|
||||
(make-string (- org-tags-column (current-column)) ?\ ))))))
|
||||
(move-overlay org-tags-overlay ov-start ov-end)
|
||||
;; Highlight tags overlay in Org buffer.
|
||||
(org-set-current-tags-overlay current-tags ov-prefix)
|
||||
;; Display tag selection dialogue, read the user input, and return.
|
||||
(save-excursion
|
||||
(save-window-excursion
|
||||
;; Select tag list buffer, and display it unless EXPERT-INTERFACE.
|
||||
(if expert-interface
|
||||
(set-buffer (get-buffer-create " *Org tags*"))
|
||||
(delete-other-windows)
|
||||
(set-window-buffer (split-window-vertically) (get-buffer-create " *Org tags*"))
|
||||
(switch-to-buffer-other-window " *Org tags*"))
|
||||
;; Fill text in *Org tags* buffer.
|
||||
(erase-buffer)
|
||||
(setq-local org-done-keywords done-keywords)
|
||||
;; Insert current tags.
|
||||
(org-fast-tag-insert "Inherited" inherited-tags inherited-face "\n")
|
||||
(org-fast-tag-insert "Current" current-tags current-face "\n\n")
|
||||
;; Display whether next change exits selection dialogue.
|
||||
(org-fast-tag-show-exit exit-after-next)
|
||||
;; Show tags, tag groups, and bindings in a grid.
|
||||
;; Each tag in the grid occupies FIELD-WIDTH characters.
|
||||
;; The tags are filled up to `window-width'.
|
||||
(setq field-number 0)
|
||||
(while (setq tag-binding-spec (pop tag-alist))
|
||||
(pcase tag-binding-spec
|
||||
;; Display tag groups on starting from a new line.
|
||||
(`(:startgroup . ,group-name)
|
||||
(push '() groups) (setq ingroup t)
|
||||
(unless (zerop field-number)
|
||||
(setq field-number 0)
|
||||
(insert "\n"))
|
||||
(insert (if group-name (format "%s: " group-name) "") "{ "))
|
||||
;; Tag group end is followed by newline.
|
||||
(`(:endgroup . ,group-name)
|
||||
(setq ingroup nil field-number 0)
|
||||
(insert "}" (if group-name (format " (%s) " group-name) "") "\n"))
|
||||
;; Group tags start at newline.
|
||||
(`(:startgrouptag)
|
||||
(setq intaggroup t)
|
||||
(unless (zerop field-number)
|
||||
(setq field-number 0)
|
||||
(insert "\n"))
|
||||
(insert "[ "))
|
||||
;; Group tags end with a newline.
|
||||
(`(:endgrouptag)
|
||||
(setq intaggroup nil field-number 0)
|
||||
(insert "]\n"))
|
||||
(`(:newline)
|
||||
(unless (zerop field-number)
|
||||
(setq field-number 0)
|
||||
(insert "\n")
|
||||
(setq tag-binding-spec (car tag-alist))
|
||||
(while (equal (car tag-alist) '(:newline))
|
||||
(insert "\n")
|
||||
(setq tag-alist (cdr tag-alist)))))
|
||||
(`(:grouptags)
|
||||
;; Previous tag is the tag representing the following group.
|
||||
;; It was inserted as "[c] TAG " with spaces filling up
|
||||
;; to the field width. Replace the trailing spaces with
|
||||
;; " : ", keeping to total field width unchanged.
|
||||
(delete-char -3)
|
||||
(insert " : "))
|
||||
(_
|
||||
(setq current-tag (copy-sequence (car tag-binding-spec))) ; will be modified by side effect
|
||||
(if (or (member current-tag char-tags)
|
||||
(and (string-prefix-p "{" current-tag)
|
||||
(string-suffix-p "}" current-tag)))
|
||||
(setq current-tag-char nil)
|
||||
;; Compute tag binding.
|
||||
(if (cdr tag-binding-spec)
|
||||
;; Custom binding.
|
||||
(setq current-tag-char (cdr tag-binding-spec))
|
||||
;; No auto-binding. Update `tag-binding-chars-left'.
|
||||
(unless (or ingroup intaggroup) ; groups are always displayed.
|
||||
(cl-decf tag-binding-chars-left))
|
||||
;; Automatically assign a character according to the tag string.
|
||||
(setq auto-tag-char
|
||||
(string-to-char
|
||||
(downcase (substring
|
||||
current-tag (if (= (string-to-char current-tag) ?@) 1 0)))))
|
||||
(if (or (rassoc auto-tag-char tag-table-local)
|
||||
(rassoc auto-tag-char tag-table))
|
||||
;; Already bound. Assign first unbound char instead.
|
||||
(progn
|
||||
(while (and tag-binding-char-list
|
||||
(or (rassoc (car tag-binding-char-list) tag-table-local)
|
||||
(rassoc (car tag-binding-char-list) tag-table)))
|
||||
(pop tag-binding-char-list))
|
||||
(setq current-tag-char (or (car tag-binding-char-list)
|
||||
;; Fall back to display "[ ]".
|
||||
?\s)))
|
||||
;; Can safely use binding derived from the tag string.
|
||||
(setq current-tag-char auto-tag-char)))
|
||||
(push current-tag char-tags))
|
||||
;; Record all the tags in the group. `:startgroup'
|
||||
;; clause earlier added '() to `groups'.
|
||||
;; `(car groups)' now contains the tag list for the
|
||||
;; current group.
|
||||
(when ingroup (push current-tag (car groups)))
|
||||
;; Compute tag face.
|
||||
(setq current-tag (org-add-props current-tag nil 'face
|
||||
(cond
|
||||
((not (assoc current-tag tag-table))
|
||||
;; The tag is from TODO-TABLE.
|
||||
(org-get-todo-face current-tag))
|
||||
((member current-tag current-tags) current-face)
|
||||
((member current-tag inherited-tags) inherited-face))))
|
||||
(when (equal (caar tag-alist) :grouptags)
|
||||
(org-add-props current-tag nil 'face 'org-tag-group))
|
||||
;; Respect `org-fast-tag-selection-maximum-tags'.
|
||||
(when (or ingroup intaggroup (cdr tag-binding-spec) (> tag-binding-chars-left 0))
|
||||
;; Insert the tag.
|
||||
(when (and (zerop field-number) (not ingroup) (not intaggroup)) (insert " "))
|
||||
(if current-tag-char
|
||||
(insert "[" current-tag-char "] ")
|
||||
(insert " "))
|
||||
(insert current-tag
|
||||
;; Fill spaces up to FIELD-WIDTH.
|
||||
(make-string
|
||||
(- field-width 4 (length current-tag)) ?\ ))
|
||||
;; Record tag and the binding/auto-binding.
|
||||
(push (cons current-tag current-tag-char) tag-table-local)
|
||||
;; Last column in the row.
|
||||
(when (= (cl-incf field-number) (/ (- (window-width) 4) field-width))
|
||||
(unless (memq (caar tag-alist) '(:endgroup :endgrouptag))
|
||||
(insert "\n")
|
||||
(when (or ingroup intaggroup) (insert " ")))
|
||||
(setq field-number 0))))))
|
||||
(insert "\n")
|
||||
;; Keep the tags in order displayed. Will be used later for sorting.
|
||||
(setq tag-table-local (nreverse tag-table-local))
|
||||
(goto-char (point-min))
|
||||
(unless expert-interface (org-fit-window-to-buffer))
|
||||
;; Read user input.
|
||||
(setq rtn
|
||||
(catch 'exit
|
||||
(while t
|
||||
(message "[a-z..]:toggle [SPC]:clear [RET]:accept [TAB]:edit [!] %sgroups%s"
|
||||
(if (not groups) "no " "")
|
||||
(if expert-interface " [C-c]:window" (if exit-after-next " [C-c]:single" " [C-c]:multi")))
|
||||
(setq input-char
|
||||
(let ((inhibit-quit t)) ; intercept C-g.
|
||||
(read-char-exclusive)))
|
||||
;; FIXME: Global variable used by `org-beamer-select-environment'.
|
||||
;; Should factor it out.
|
||||
(setq org-last-tag-selection-key input-char)
|
||||
(pcase input-char
|
||||
;; <RET>
|
||||
(?\r (throw 'exit t))
|
||||
;; Toggle tag groups.
|
||||
(?!
|
||||
(setq groups (not groups))
|
||||
(goto-char (point-min))
|
||||
(while (re-search-forward "[{}]" nil t) (replace-match " ")))
|
||||
;; Toggle expert interface.
|
||||
(?\C-c
|
||||
(if (not expert-interface)
|
||||
(org-fast-tag-show-exit
|
||||
(setq exit-after-next (not exit-after-next)))
|
||||
(setq expert-interface nil)
|
||||
(delete-other-windows)
|
||||
(set-window-buffer (split-window-vertically) " *Org tags*")
|
||||
(switch-to-buffer-other-window " *Org tags*")
|
||||
(org-fit-window-to-buffer)))
|
||||
;; Quit.
|
||||
((or ?\C-g
|
||||
(and ?q (guard (not (rassoc input-char tag-table-local)))))
|
||||
(delete-overlay org-tags-overlay)
|
||||
;; Quit as C-g does.
|
||||
(keyboard-quit))
|
||||
;; Clear tags.
|
||||
(?\s
|
||||
(setq current-tags nil)
|
||||
(when exit-after-next (setq exit-after-next 'now)))
|
||||
;; Use normal completion.
|
||||
(?\t
|
||||
;; Compute completion table, unless already computed.
|
||||
(unless tab-tags
|
||||
(setq tab-tags
|
||||
(delq nil
|
||||
(mapcar (lambda (x)
|
||||
(let ((item (car-safe x)))
|
||||
(and (stringp item)
|
||||
(list item))))
|
||||
;; Complete using all tags; tags from current buffer first.
|
||||
(org--tag-add-to-alist
|
||||
(with-current-buffer origin-buffer
|
||||
(org-get-buffer-tags))
|
||||
tag-table)))))
|
||||
(setq current-tag (completing-read "Tag: " tab-tags))
|
||||
(when (string-match "\\S-" current-tag)
|
||||
(cl-pushnew (list current-tag) tab-tags :test #'equal)
|
||||
(setq current-tags (org--add-or-remove-tag current-tag current-tags groups)))
|
||||
(when exit-after-next (setq exit-after-next 'now)))
|
||||
;; INPUT-CHAR is for a todo keyword.
|
||||
((let (and todo-keyword (guard todo-keyword))
|
||||
(car (rassoc input-char todo-table)))
|
||||
(with-current-buffer origin-buffer
|
||||
(save-excursion (org-todo todo-keyword)))
|
||||
(when exit-after-next (setq exit-after-next 'now)))
|
||||
;; INPUT-CHAR is for a tag.
|
||||
((let (and tag (guard tag))
|
||||
(car (rassoc input-char tag-table-local)))
|
||||
(setq current-tags (org--add-or-remove-tag tag current-tags groups))
|
||||
(when exit-after-next (setq exit-after-next 'now))))
|
||||
;; Create a sorted tag list.
|
||||
(setq current-tags
|
||||
(sort current-tags
|
||||
(lambda (a b)
|
||||
;; b is after a.
|
||||
;; `memq' returns tail of the list after the match + the match.
|
||||
(assoc b (cdr (memq (assoc a tag-table-local) tag-table-local))))))
|
||||
;; Exit when we are set to exit immediately.
|
||||
(when (eq exit-after-next 'now) (throw 'exit t))
|
||||
;; Continue setting tags in the loop.
|
||||
;; Update the currently active tags indication in the completion buffer.
|
||||
(goto-char (point-min))
|
||||
(forward-line 1)
|
||||
(delete-region (point) (line-end-position))
|
||||
(org-fast-tag-insert "Current" current-tags current-face)
|
||||
;; Update the active tags displayed in the overlay in Org buffer.
|
||||
(org-set-current-tags-overlay current-tags ov-prefix)
|
||||
;; Update tag faces in the displayed tag grid.
|
||||
(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-tags) current-face)
|
||||
((member tag inherited-tags) inherited-face)
|
||||
(t 'default)))))))
|
||||
(goto-char (point-min)))))
|
||||
;; Clear the tag overlay in Org buffer.
|
||||
(delete-overlay org-tags-overlay)
|
||||
;; Return the new tag list.
|
||||
(if rtn
|
||||
(mapconcat 'identity current-tags ":")
|
||||
nil)))))
|
||||
#+end_src
|
||||
|
||||
The last problem is that Org automatically assigns keys alphabetically if not specified, which means keys can often be difficult to reach. To fix this, we can simply configure some variables.
|
||||
|
||||
#+begin_src emacs-lisp
|
||||
(after! org
|
||||
(setq org--fast-tag-selection-keys
|
||||
(string-to-list "asdfghjklrueitywovnASDFGHJKLRUEITYWOVN")
|
||||
org-fast-tag-selection-maximum-tags 40))
|
||||
#+end_src
|
||||
|
||||
*** Export Directory
|
||||
|
||||
Org mode by default exports to the same directory the org-mode file is in. This is inconvenient for me, as I use a lot of subdirectories. To fix this, we can advise the function ~org-export-output-file-name~.
|
||||
|
|
|
|||
Loading…
Reference in a new issue