consult-org.el (5811B)
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 todo 79 (put-text-property 0 (length todo) 'face (org-get-todo-face todo) todo)) 80 (when tags 81 (put-text-property 0 (length tags) 'face 'org-tag tags)) 82 (setq cand (concat (and prefix buffer) (and prefix " ") cand (and tags " ") 83 tags (consult--tofu-encode idx))) 84 (cl-incf idx) 85 (add-text-properties 0 1 86 `(org-marker ,(point-marker) 87 consult-org--heading (,level ,todo ,prio . ,buffer)) 88 cand) 89 cand)) 90 match scope skip))) 91 92 (defun consult-org--annotate (cand) 93 "Annotate CAND for `consult-org-heading'." 94 (pcase-let ((`(,_level ,todo ,prio . ,_) 95 (get-text-property 0 'consult-org--heading cand))) 96 (consult--annotate-align 97 cand 98 (concat todo 99 (and prio (format #(" [#%c]" 1 6 (face org-priority)) prio)))))) 100 101 (defun consult-org--group (cand transform) 102 "Return title for CAND or TRANSFORM the candidate." 103 (pcase-let ((`(,_level ,_todo ,_prio . ,buffer) 104 (get-text-property 0 'consult-org--heading cand))) 105 (if transform (substring cand (1+ (length buffer))) buffer))) 106 107 ;;;###autoload 108 (defun consult-org-heading (&optional match scope) 109 "Jump to an Org heading. 110 111 MATCH and SCOPE are as in `org-map-entries' and determine which 112 entries are offered. By default, all entries of the current 113 buffer are offered." 114 (interactive (unless (derived-mode-p #'org-mode) 115 (user-error "Must be called from an Org buffer"))) 116 (let ((prefix (not (memq scope '(nil tree region region-start-level file))))) 117 (consult--read 118 (consult--slow-operation "Collecting headings..." 119 (or (consult-org--headings prefix match scope) 120 (user-error "No headings"))) 121 :prompt "Go to heading: " 122 :category 'org-heading 123 :sort nil 124 :require-match t 125 :history '(:input consult-org--history) 126 :narrow (consult-org--narrow) 127 :state (consult--jump-state) 128 :annotate #'consult-org--annotate 129 :group (and prefix #'consult-org--group) 130 :lookup (apply-partially #'consult--lookup-prop 'org-marker)))) 131 132 ;;;###autoload 133 (defun consult-org-agenda (&optional match) 134 "Jump to an Org agenda heading. 135 136 By default, all agenda entries are offered. MATCH is as in 137 `org-map-entries' and can used to refine this." 138 (interactive) 139 (unless org-agenda-files 140 (user-error "No agenda files")) 141 (consult-org-heading match 'agenda)) 142 143 (provide 'consult-org) 144 ;;; consult-org.el ends here