consult-org.el (6336B)
1 ;;; consult-org.el --- Consult commands for org-mode -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2021-2024 Free Software Foundation, Inc. 4 5 ;; This file is part of GNU Emacs. 6 7 ;; This program is free software: you can redistribute it and/or modify 8 ;; it under the terms of the GNU General Public License as published by 9 ;; the Free Software Foundation, either version 3 of the License, or 10 ;; (at your option) any later version. 11 12 ;; This program is distributed in the hope that it will be useful, 13 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of 14 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15 ;; GNU General Public License for more details. 16 17 ;; You should have received a copy of the GNU General Public License 18 ;; along with this program. If not, see <https://www.gnu.org/licenses/>. 19 20 ;;; Commentary: 21 22 ;; Provides a `completing-read' interface for Org mode navigation. 23 ;; This is an extra package, to allow lazy loading of Org. 24 25 ;;; Code: 26 27 (require 'consult) 28 (require 'org) 29 30 (defvar consult-org--history nil) 31 32 (defun consult-org--narrow () 33 "Narrowing configuration for `consult-org' commands." 34 (let ((todo-kws 35 (seq-filter 36 (lambda (x) (<= ?a (car x) ?z)) 37 (mapcar (lambda (s) 38 (pcase-let ((`(,a ,b) (split-string s "("))) 39 (cons (downcase (string-to-char (or b a))) a))) 40 (apply #'append (mapcar #'cdr org-todo-keywords)))))) 41 (list :predicate 42 (lambda (cand) 43 (pcase-let ((`(,level ,todo . ,prio) 44 (get-text-property 0 'consult-org--heading cand))) 45 (cond 46 ((<= ?1 consult--narrow ?9) (<= level (- consult--narrow ?0))) 47 ((<= ?A consult--narrow ?Z) (eq prio consult--narrow)) 48 (t (equal todo (alist-get consult--narrow todo-kws)))))) 49 :keys 50 (nconc (mapcar (lambda (c) (cons c (format "Level %c" c))) 51 (number-sequence ?1 ?9)) 52 (mapcar (lambda (c) (cons c (format "Priority %c" c))) 53 (number-sequence (max ?A org-highest-priority) 54 (min ?Z org-lowest-priority))) 55 todo-kws)))) 56 57 (defun consult-org--headings (prefix match scope &rest skip) 58 "Return a list of Org heading candidates. 59 60 If PREFIX is non-nil, prefix the candidates with the buffer name. 61 MATCH, SCOPE and SKIP are as in `org-map-entries'." 62 (let (buffer (idx 0)) 63 (apply 64 #'org-map-entries 65 (lambda () 66 ;; Reset the cache when the buffer changes, since `org-get-outline-path' uses the cache 67 (unless (eq buffer (buffer-name)) 68 (setq buffer (buffer-name) 69 org-outline-path-cache nil)) 70 (pcase-let* ((`(_ ,level ,todo ,prio ,_hl ,tags) (org-heading-components)) 71 (tags (if org-use-tag-inheritance 72 (when-let ((tags (org-get-tags))) 73 (concat ":" (string-join tags ":") ":")) 74 tags)) 75 (cand (org-format-outline-path 76 (org-get-outline-path 'with-self 'use-cache) 77 most-positive-fixnum))) 78 (when tags 79 (put-text-property 0 (length tags) 'face 'org-tag tags)) 80 (setq cand (if prefix 81 (concat buffer " " cand (and tags " ") 82 tags (consult--tofu-encode idx)) 83 (concat cand (and tags " ") 84 tags (consult--tofu-encode idx)))) 85 (cl-incf idx) 86 (add-text-properties 0 1 87 `(org-marker ,(point-marker) 88 consult-org--heading (,level ,todo . ,prio)) 89 cand) 90 cand)) 91 match scope skip))) 92 93 (defun consult-org--annotate () 94 "Generate annotation function for `consult-org-heading'." 95 (let (buf) 96 (when (derived-mode-p #'org-mode) 97 (setq buf (current-buffer))) 98 (lambda (cand) 99 (unless (buffer-live-p buf) 100 (setq buf (seq-find (lambda (b) 101 (with-current-buffer b (derived-mode-p #'org-mode))) 102 (buffer-list)))) 103 (pcase-let ((`(,_level ,kwd . ,prio) 104 (get-text-property 0 'consult-org--heading cand))) 105 (consult--annotate-align 106 cand 107 (concat 108 (propertize (or kwd "") 'face 109 (with-current-buffer (or buf (current-buffer)) 110 ;; `org-get-todo-face' must be called inside an Org buffer 111 (org-get-todo-face kwd))) 112 (and prio (format #(" [#%c]" 1 6 (face org-priority)) prio)))))))) 113 114 ;;;###autoload 115 (defun consult-org-heading (&optional match scope) 116 "Jump to an Org heading. 117 118 MATCH and SCOPE are as in `org-map-entries' and determine which 119 entries are offered. By default, all entries of the current 120 buffer are offered." 121 (interactive (unless (derived-mode-p #'org-mode) 122 (user-error "Must be called from an Org buffer"))) 123 (let ((prefix (not (memq scope '(nil tree region region-start-level file))))) 124 (consult--read 125 (consult--slow-operation "Collecting headings..." 126 (or (consult-org--headings prefix match scope) 127 (user-error "No headings"))) 128 :prompt "Go to heading: " 129 :category 'org-heading 130 :sort nil 131 :require-match t 132 :history '(:input consult-org--history) 133 :narrow (consult-org--narrow) 134 :state (consult--jump-state) 135 :annotate (consult-org--annotate) 136 :group 137 (when prefix 138 (lambda (cand transform) 139 (let ((name (buffer-name 140 (marker-buffer 141 (get-text-property 0 'org-marker cand))))) 142 (if transform (substring cand (1+ (length name))) name)))) 143 :lookup (apply-partially #'consult--lookup-prop 'org-marker)))) 144 145 ;;;###autoload 146 (defun consult-org-agenda (&optional match) 147 "Jump to an Org agenda heading. 148 149 By default, all agenda entries are offered. MATCH is as in 150 `org-map-entries' and can used to refine this." 151 (interactive) 152 (unless org-agenda-files 153 (user-error "No agenda files")) 154 (consult-org-heading match 'agenda)) 155 156 (provide 'consult-org) 157 ;;; consult-org.el ends here