dotemacs

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

consult-org.el (4878B)

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