consult-org.el (5399B)
1 ;;; consult-org.el --- Consult commands for org-mode -*- lexical-binding: t -*- 2 3 ;; Copyright (C) 2021-2023 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 `(consult--candidate ,(point-marker) 88 consult-org--heading (,level ,todo . ,prio)) 89 cand) 90 cand)) 91 match scope skip))) 92 93 ;;;###autoload 94 (defun consult-org-heading (&optional match scope) 95 "Jump to an Org heading. 96 97 MATCH and SCOPE are as in `org-map-entries' and determine which 98 entries are offered. By default, all entries of the current 99 buffer are offered." 100 (interactive (unless (derived-mode-p 'org-mode) 101 (user-error "Must be called from an Org buffer"))) 102 (let ((prefix (not (memq scope '(nil tree region region-start-level file))))) 103 (consult--read 104 (consult--slow-operation "Collecting headings..." 105 (or (consult-org--headings prefix match scope) 106 (user-error "No headings"))) 107 :prompt "Go to heading: " 108 :category 'consult-org-heading 109 :sort nil 110 :require-match t 111 :history '(:input consult-org--history) 112 :narrow (consult-org--narrow) 113 :state (consult--jump-state) 114 :group 115 (when prefix 116 (lambda (cand transform) 117 (let ((name (buffer-name 118 (marker-buffer 119 (get-text-property 0 'consult--candidate cand))))) 120 (if transform (substring cand (1+ (length name))) name)))) 121 :lookup #'consult--lookup-candidate))) 122 123 ;;;###autoload 124 (defun consult-org-agenda (&optional match) 125 "Jump to an Org agenda heading. 126 127 By default, all agenda entries are offered. MATCH is as in 128 `org-map-entries' and can used to refine this." 129 (interactive) 130 (unless org-agenda-files 131 (user-error "No agenda files")) 132 (consult-org-heading match 'agenda)) 133 134 (provide 'consult-org) 135 ;;; consult-org.el ends here