Function: org-fast-tag-selection
org-fast-tag-selection is a byte-compiled function defined in
org.el.gz.
Signature
(org-fast-tag-selection CURRENT-TAGS INHERITED-TAGS TAG-TABLE &optional TODO-TABLE)
Documentation
Fast tag selection with single keys.
CURRENT-TAGS is the current list of tags in the headline, INHERITED-TAGS is the list of inherited tags, and TAG-TABLE is an alist of tags and corresponding keys, possibly with grouping information. TODO-TABLE is a similar table with TODO keywords, should these have keys assigned to them. If the keys are nil, a-z are automatically assigned. Returns the new tags string, or nil to not change the current settings.
Source Code
;; Defined in /usr/src/emacs/lisp/org/org.el.gz
(defun org-fast-tag-selection (current-tags inherited-tags tag-table &optional todo-table)
"Fast tag selection with single keys.
CURRENT-TAGS is the current list of tags in the headline,
INHERITED-TAGS is the list of inherited tags, and TAG-TABLE is an
alist of tags and corresponding keys, possibly with grouping
information. TODO-TABLE is a similar table with TODO keywords, should
these have keys assigned to them.
If the keys are nil, a-z are automatically assigned.
Returns the new tags string, or nil to not change the current settings."
(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)
;; 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 dialog, 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*"))
(pop-to-buffer
(get-buffer-create " *Org tags*")
'(org-display-buffer-split (direction . down))))
;; 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 dialog.
(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
;; 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)))
;; 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 " "))
(insert "[" current-tag-char "] " 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)
(pop-to-buffer
" *Org tags*"
'((org-display-buffer-split (direction down))))
(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)))))