dotemacs

My Emacs configuration
git clone git://git.entf.net/dotemacs
Log | Files | Refs | LICENSE

consult-org.el (4955B)

      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)
     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                    (cand (org-format-outline-path
     72                           (org-get-outline-path 'with-self 'use-cache)
     73                           most-positive-fixnum)))
     74          (when tags
     75            (setq tags (concat " " (propertize tags 'face 'org-tag))))
     76          (setq cand (if prefix
     77                         (concat buffer " " cand tags (consult--tofu-encode (point)))
     78                       (concat cand tags (consult--tofu-encode (point)))))
     79          (add-text-properties 0 1
     80                               `(consult--candidate ,(point-marker)
     81                                 consult-org--heading (,level ,todo . ,prio))
     82                               cand)
     83          cand))
     84      match scope skip)))
     85 
     86 ;;;###autoload
     87 (defun consult-org-heading (&optional match scope)
     88   "Jump to an Org heading.
     89 
     90 MATCH and SCOPE are as in `org-map-entries' and determine which
     91 entries are offered.  By default, all entries of the current
     92 buffer are offered."
     93   (interactive (unless (derived-mode-p 'org-mode)
     94                  (user-error "Must be called from an Org buffer")))
     95   (let ((prefix (not (memq scope '(nil tree region region-start-level file)))))
     96     (consult--read
     97      (consult-org--headings prefix match scope)
     98      :prompt "Go to heading: "
     99      :category 'consult-org-heading
    100      :sort nil
    101      :require-match t
    102      :history '(:input consult-org--history)
    103      :narrow (consult-org--narrow)
    104      :state (consult--jump-state)
    105      :group
    106      (when prefix
    107        (lambda (cand transform)
    108          (let ((name (buffer-name
    109                       (marker-buffer
    110                        (get-text-property 0 'consult--candidate cand)))))
    111            (if transform (substring cand (1+ (length name))) name))))
    112      :lookup #'consult--lookup-candidate)))
    113 
    114 ;;;###autoload
    115 (defun consult-org-agenda (&optional match)
    116   "Jump to an Org agenda heading.
    117 
    118 By default, all agenda entries are offered. MATCH is as in
    119 `org-map-entries' and can used to refine this."
    120   (interactive)
    121   (unless org-agenda-files
    122     (user-error "No agenda files"))
    123   (consult-org-heading match 'agenda))
    124 
    125 (provide 'consult-org)
    126 ;;; consult-org.el ends here