contrib/lisp/org-toc.el

   1 ;;; org-toc.el --- Table of contents for Org-mode buffer
   2
   3 ;; Copyright 2007-2017 Free Software Foundation, Inc.
   4 ;;
   5 ;; Author: Bastien Guerry <bzg@gnu.org>
   6 ;; Keywords: Org table of contents
   7 ;; Homepage: http://www.cognition.ens.fr/~guerry/u/org-toc.el
   8 ;; Version: 0.8
   9
  10 ;; This file is not part of GNU Emacs.
  11
  12 ;; This program is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 3, or (at your option)
  15 ;; any later version.
  16 ;;
  17 ;; This program is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21 ;;
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This library implements a browsable table of contents for Org files.
  28
  29 ;; Put this file into your load-path and the following into your ~/.emacs:
  30 ;;   (require 'org-toc)
  31
  32 ;;; Code:
  33
  34 (provide 'org-toc)
  35 (eval-when-compile
  36   (require 'cl))
  37
  38 ;;; Custom variables:
  39 (defvar org-toc-base-buffer nil)
  40 (defvar org-toc-columns-shown nil)
  41 (defvar org-toc-odd-levels-only nil)
  42 (defvar org-toc-config-alist nil)
  43 (defvar org-toc-cycle-global-status nil)
  44 (defalias 'org-show-table-of-contents 'org-toc-show)
  45
  46 (defgroup org-toc nil
  47   "Options concerning the browsable table of contents of Org-mode."
  48   :tag "Org TOC"
  49   :group 'org)
  50
  51 (defcustom org-toc-default-depth 1
  52   "Default depth when invoking `org-toc-show' without argument."
  53   :group 'org-toc
  54   :type '(choice
  55           (const :tag "same as base buffer" nil)
  56           (integer :tag "level")))
  57
  58 (defcustom org-toc-follow-mode nil
  59   "Non-nil means navigating through the table of contents will
  60 move the point in the Org buffer accordingly."
  61   :group 'org-toc
  62   :type 'boolean)
  63
  64 (defcustom org-toc-info-mode nil
  65   "Non-nil means navigating through the table of contents will
  66 show the properties for the current headline in the echo-area."
  67   :group 'org-toc
  68   :type 'boolean)
  69
  70 (defcustom org-toc-show-subtree-mode nil
  71   "Non-nil means show subtree when going to headline or following
  72 it while browsing the table of contents."
  73   :group 'org-toc
  74   :type '(choice
  75           (const :tag "show subtree" t)
  76           (const :tag "show entry" nil)))
  77
  78 (defcustom org-toc-recenter-mode t
  79   "Non-nil means recenter the Org buffer when following the
  80 headlines in the TOC buffer."
  81   :group 'org-toc
  82   :type 'boolean)
  83
  84 (defcustom org-toc-recenter 0
  85   "Where to recenter the Org buffer when unfolding a subtree.
  86 This variable is only used when `org-toc-recenter-mode' is set to
  87 'custom. A value >=1000 will call recenter with no arg."
  88   :group 'org-toc
  89   :type 'integer)
  90
  91 (defcustom org-toc-info-exclude '("ALLTAGS")
  92   "A list of excluded properties when displaying info in the
  93 echo-area. The COLUMNS property is always exluded."
  94   :group 'org-toc
  95   :type 'lits)
  96
  97 ;;; Org TOC mode:
  98 (defvar org-toc-mode-map (make-sparse-keymap)
  99   "Keymap for `org-toc-mode'.")
 100
 101 (defun org-toc-mode ()
 102   "A major mode for browsing the table of contents of an Org buffer.
 103
 104 \\{org-toc-mode-map}"
 105   (interactive)
 106   (kill-all-local-variables)
 107   (use-local-map org-toc-mode-map)
 108   (setq mode-name "Org TOC")
 109   (setq major-mode 'org-toc-mode))
 110
 111 ;; toggle modes
 112 (define-key org-toc-mode-map "F" 'org-toc-follow-mode)
 113 (define-key org-toc-mode-map "S" 'org-toc-show-subtree-mode)
 114 (define-key org-toc-mode-map "s" 'org-toc-store-config)
 115 (define-key org-toc-mode-map "g" 'org-toc-restore-config)
 116 (define-key org-toc-mode-map "i" 'org-toc-info-mode)
 117 (define-key org-toc-mode-map "r" 'org-toc-recenter-mode)
 118
 119 ;; navigation keys
 120 (define-key org-toc-mode-map "p" 'org-toc-previous)
 121 (define-key org-toc-mode-map "n" 'org-toc-next)
 122 (define-key org-toc-mode-map "f" 'org-toc-forward)
 123 (define-key org-toc-mode-map "b" 'org-toc-back)
 124 (define-key org-toc-mode-map [(left)] 'org-toc-back)
 125 (define-key org-toc-mode-map [(right)] 'org-toc-forward)
 126 (define-key org-toc-mode-map [(up)] 'org-toc-previous)
 127 (define-key org-toc-mode-map [(down)] 'org-toc-next)
 128 (define-key org-toc-mode-map "1" (lambda() (interactive) (org-toc-show 1 (point))))
 129 (define-key org-toc-mode-map "2" (lambda() (interactive) (org-toc-show 2 (point))))
 130 (define-key org-toc-mode-map "3" (lambda() (interactive) (org-toc-show 3 (point))))
 131 (define-key org-toc-mode-map "4" (lambda() (interactive) (org-toc-show 4 (point))))
 132 (define-key org-toc-mode-map " " 'org-toc-goto)
 133 (define-key org-toc-mode-map "q" 'org-toc-quit)
 134 (define-key org-toc-mode-map "x" 'org-toc-quit)
 135 ;; go to the location and stay in the base buffer
 136 (define-key org-toc-mode-map [(tab)] 'org-toc-jump)
 137 (define-key org-toc-mode-map "v" 'org-toc-jump)
 138 ;; go to the location and delete other windows
 139 (define-key org-toc-mode-map [(return)]
 140   (lambda() (interactive) (org-toc-jump t)))
 141
 142 ;; special keys
 143 (define-key org-toc-mode-map "c" 'org-toc-columns)
 144 (define-key org-toc-mode-map "?" 'org-toc-help)
 145 (define-key org-toc-mode-map ":" 'org-toc-cycle-subtree)
 146 (define-key org-toc-mode-map "\C-c\C-o" 'org-open-at-point)
 147 ;; global cycling in the base buffer
 148 (define-key org-toc-mode-map (kbd "C-S-<iso-lefttab>")
 149   'org-toc-cycle-base-buffer)
 150 ;; subtree cycling in the base buffer
 151 (define-key org-toc-mode-map [(control tab)]
 152   (lambda() (interactive) (org-toc-goto nil t)))
 153
 154 ;;; Toggle functions:
 155 (defun org-toc-follow-mode ()
 156   "Toggle follow mode in a `org-toc-mode' buffer."
 157   (interactive)
 158   (setq org-toc-follow-mode (not org-toc-follow-mode))
 159   (message "Follow mode is %s"
 160            (if org-toc-follow-mode "on" "off")))
 161
 162 (defun org-toc-info-mode ()
 163   "Toggle info mode in a `org-toc-mode' buffer."
 164   (interactive)
 165   (setq org-toc-info-mode (not org-toc-info-mode))
 166   (message "Info mode is %s"
 167            (if org-toc-info-mode "on" "off")))
 168
 169 (defun org-toc-show-subtree-mode ()
 170   "Toggle show subtree mode in a `org-toc-mode' buffer."
 171   (interactive)
 172   (setq org-toc-show-subtree-mode (not org-toc-show-subtree-mode))
 173   (message "Show subtree mode is %s"
 174            (if org-toc-show-subtree-mode "on" "off")))
 175
 176 (defun org-toc-recenter-mode (&optional line)
 177   "Toggle recenter mode in a `org-toc-mode' buffer. If LINE is
 178 specified, then make `org-toc-recenter' use this value."
 179   (interactive "P")
 180   (setq org-toc-recenter-mode (not org-toc-recenter-mode))
 181   (when (numberp line)
 182     (setq org-toc-recenter-mode t)
 183     (setq org-toc-recenter line))
 184   (message "Recenter mode is %s"
 185            (if org-toc-recenter-mode
 186                (format "on, line %d" org-toc-recenter) "off")))
 187
 188 (defun org-toc-cycle-subtree ()
 189   "Locally cycle a headline through two states: 'children and
 190 'folded"
 191   (interactive)
 192   (let ((beg (point))
 193         (end (save-excursion (end-of-line) (point)))
 194         (ov (car (overlays-at (point))))
 195         status)
 196     (if ov (setq status (overlay-get ov 'status))
 197       (setq ov (make-overlay beg end)))
 198     ;; change the folding status of this headline
 199     (cond ((or (null status) (eq status 'folded))
 200            (org-show-children)
 201            (message "CHILDREN")
 202            (overlay-put ov 'status 'children))
 203           ((eq status 'children)
 204            (show-branches)
 205            (message "BRANCHES")
 206            (overlay-put ov 'status 'branches))
 207           (t (hide-subtree)
 208              (message "FOLDED")
 209              (overlay-put ov 'status 'folded)))))
 210
 211 ;;; Main show function:
 212 ;; FIXME name this org-before-first-heading-p?
 213 (defun org-toc-before-first-heading-p ()
 214   "Before first heading?"
 215   (save-excursion
 216     (null (re-search-backward org-outline-regexp-bol nil t))))
 217
 218 ;;;###autoload
 219 (defun org-toc-show (&optional depth position)
 220   "Show the table of contents of the current Org-mode buffer."
 221   (interactive "P")
 222   (if (eq major-mode 'org-mode)
 223       (progn (setq org-toc-base-buffer (current-buffer))
 224              (setq org-toc-odd-levels-only org-odd-levels-only))
 225     (if (eq major-mode 'org-toc-mode)
 226         (org-pop-to-buffer-same-window org-toc-base-buffer)
 227       (error "Not in an Org buffer")))
 228   ;; create the new window display
 229   (let ((pos (or position
 230                  (save-excursion
 231                    (if (org-toc-before-first-heading-p)
 232                        (progn (re-search-forward org-outline-regexp-bol nil t)
 233                               (match-beginning 0))
 234                      (point))))))
 235     (setq org-toc-cycle-global-status org-cycle-global-status)
 236     (delete-other-windows)
 237     (and (get-buffer "*org-toc*") (kill-buffer "*org-toc*"))
 238     (switch-to-buffer-other-window
 239      (make-indirect-buffer org-toc-base-buffer "*org-toc*"))
 240     ;; make content before 1st headline invisible
 241     (goto-char (point-min))
 242     (let* ((beg (point-min))
 243            (end (and (re-search-forward "^\\*" nil t)
 244                      (1- (match-beginning 0))))
 245            (ov (make-overlay beg end))
 246            (help (format "Table of contents for %s (press ? for a quick help):\n"
 247                          (buffer-name org-toc-base-buffer))))
 248       (overlay-put ov 'invisible t)
 249       (overlay-put ov 'before-string help))
 250     ;; build the browsable TOC
 251     (cond (depth
 252            (let* ((dpth (if org-toc-odd-levels-only
 253                             (1- (* depth 2)) depth)))
 254              (org-content dpth)
 255              (setq org-toc-cycle-global-status
 256                    `(org-content ,dpth))))
 257            ((null org-toc-default-depth)
 258             (if (eq org-toc-cycle-global-status 'overview)
 259                 (progn (org-overview)
 260                        (setq org-cycle-global-status 'overview)
 261                        (run-hook-with-args 'org-cycle-hook 'overview))
 262               (progn (org-overview)
 263                      ;; FIXME org-content to show only headlines?
 264                      (org-content)
 265                      (setq org-cycle-global-status 'contents)
 266                      (run-hook-with-args 'org-cycle-hook 'contents))))
 267            (t (let* ((dpth0 org-toc-default-depth)
 268                      (dpth (if org-toc-odd-levels-only
 269                                (1- (* dpth0 2)) dpth0)))
 270                 (org-content dpth)
 271                 (setq org-toc-cycle-global-status
 272                       `(org-content ,dpth)))))
 273     (goto-char pos))
 274   (move-beginning-of-line nil)
 275   (org-toc-mode)
 276   (shrink-window-if-larger-than-buffer)
 277   (setq buffer-read-only t))
 278
 279 ;;; Navigation functions:
 280 (defun org-toc-goto (&optional jump cycle)
 281   "From Org TOC buffer, follow the targeted subtree in the Org window.
 282 If JUMP is non-nil, go to the base buffer.
 283 If JUMP is 'delete, go to the base buffer and delete other windows.
 284 If CYCLE is non-nil, cycle the targeted subtree in the Org window."
 285   (interactive)
 286   (let ((pos (point))
 287         (toc-buf (current-buffer)))
 288     (switch-to-buffer-other-window org-toc-base-buffer)
 289     (goto-char pos)
 290     (if cycle (org-cycle)
 291       (progn (org-overview)
 292              (if org-toc-show-subtree-mode
 293                  (org-show-subtree)
 294                (org-show-entry))
 295              (org-show-context)))
 296     (if org-toc-recenter-mode
 297         (if (>= org-toc-recenter 1000) (recenter)
 298           (recenter org-toc-recenter)))
 299     (cond ((null jump)
 300            (switch-to-buffer-other-window toc-buf))
 301           ((eq jump 'delete)
 302            (delete-other-windows)))))
 303
 304 (defun org-toc-cycle-base-buffer ()
 305   "Call `org-cycle' with a prefix argument in the base buffer."
 306   (interactive)
 307   (switch-to-buffer-other-window org-toc-base-buffer)
 308   (org-cycle t)
 309   (other-window 1))
 310
 311 (defun org-toc-jump (&optional delete)
 312   "From Org TOC buffer, jump to the targeted subtree in the Org window.
 313 If DELETE is non-nil, delete other windows when in the Org buffer."
 314   (interactive "P")
 315   (if delete (org-toc-goto 'delete)
 316     (org-toc-goto t)))
 317
 318 (defun org-toc-previous ()
 319   "Go to the previous headline of the TOC."
 320   (interactive)
 321   (if (save-excursion
 322           (beginning-of-line)
 323           (re-search-backward "^\\*" nil t))
 324     (outline-previous-visible-heading 1)
 325     (message "No previous heading"))
 326   (if org-toc-info-mode (org-toc-info))
 327   (if org-toc-follow-mode (org-toc-goto)))
 328
 329 (defun org-toc-next ()
 330   "Go to the next headline of the TOC."
 331   (interactive)
 332   (outline-next-visible-heading 1)
 333   (if org-toc-info-mode (org-toc-info))
 334   (if org-toc-follow-mode (org-toc-goto)))
 335
 336 (defun org-toc-forward ()
 337   "Go to the next headline at the same level in the TOC."
 338   (interactive)
 339   (condition-case nil
 340       (outline-forward-same-level 1)
 341     (error (message "No next headline at this level")))
 342   (if org-toc-info-mode (org-toc-info))
 343   (if org-toc-follow-mode (org-toc-goto)))
 344
 345 (defun org-toc-back ()
 346   "Go to the previous headline at the same level in the TOC."
 347   (interactive)
 348   (condition-case nil
 349       (outline-backward-same-level 1)
 350     (error (message "No previous headline at this level")))
 351   (if org-toc-info-mode (org-toc-info))
 352   (if org-toc-follow-mode (org-toc-goto)))
 353
 354 (defun org-toc-quit ()
 355   "Quit the current Org TOC buffer."
 356   (interactive)
 357   (kill-this-buffer)
 358   (other-window 1)
 359   (delete-other-windows))
 360
 361 ;;; Special functions:
 362 (defun org-toc-columns ()
 363   "Toggle columns view in the Org buffer from Org TOC."
 364   (interactive)
 365   (let ((indirect-buffer (current-buffer)))
 366     (org-pop-to-buffer-same-window org-toc-base-buffer)
 367     (if (not org-toc-columns-shown)
 368         (progn (org-columns)
 369                (setq org-toc-columns-shown t))
 370       (progn (org-columns-remove-overlays)
 371              (setq org-toc-columns-shown nil)))
 372     (org-pop-to-buffer-same-window indirect-buffer)))
 373
 374 (defun org-toc-info ()
 375   "Show properties of current subtree in the echo-area."
 376   (interactive)
 377   (let ((pos (point))
 378         (indirect-buffer (current-buffer))
 379         props prop msg)
 380     (org-pop-to-buffer-same-window org-toc-base-buffer)
 381     (goto-char pos)
 382     (setq props (org-entry-properties))
 383     (while (setq prop (pop props))
 384       (unless (or (equal (car prop) "COLUMNS")
 385                   (member (car prop) org-toc-info-exclude))
 386         (let ((p (car prop))
 387               (v (cdr prop)))
 388           (if (equal p "TAGS")
 389               (setq v (mapconcat 'identity (split-string v ":" t) " ")))
 390           (setq p (concat p ":"))
 391           (add-text-properties 0 (length p) '(face org-special-keyword) p)
 392           (setq msg (concat msg p " " v "  ")))))
 393     (org-pop-to-buffer-same-window indirect-buffer)
 394     (message msg)))
 395
 396 ;;; Store and restore TOC configuration:
 397 (defun org-toc-store-config ()
 398   "Store the current status of the tables of contents in
 399 `org-toc-config-alist'."
 400   (interactive)
 401   (let ((file (buffer-file-name org-toc-base-buffer))
 402         (pos (point))
 403         (hlcfg (org-toc-get-headlines-status)))
 404     (setq org-toc-config-alist
 405           (delete (assoc file org-toc-config-alist)
 406                   org-toc-config-alist))
 407     (add-to-list 'org-toc-config-alist
 408                  `(,file ,pos ,org-toc-cycle-global-status ,hlcfg))
 409     (message "TOC configuration saved: (%s)"
 410              (if (listp org-toc-cycle-global-status)
 411                  (concat "org-content "
 412                          (number-to-string
 413                           (cadr org-toc-cycle-global-status)))
 414                (symbol-name org-toc-cycle-global-status)))))
 415
 416 (defun org-toc-restore-config ()
 417   "Get the stored status in `org-toc-config-alist' and set the
 418 current table of contents to it."
 419   (interactive)
 420   (let* ((file (buffer-file-name org-toc-base-buffer))
 421          (conf (cdr (assoc file org-toc-config-alist)))
 422          (pos (car conf))
 423          (status (cadr conf))
 424          (hlcfg (caddr conf)) hlcfg0 ov)
 425     (cond ((listp status)
 426            (org-toc-show (cadr status) (point)))
 427           ((eq status 'overview)
 428            (org-overview)
 429            (setq org-cycle-global-status 'overview)
 430            (run-hook-with-args 'org-cycle-hook 'overview))
 431           (t
 432            (org-overview)
 433            (org-content)
 434            (setq org-cycle-global-status 'contents)
 435            (run-hook-with-args 'org-cycle-hook 'contents)))
 436     (while (setq hlcfg0 (pop hlcfg))
 437       (save-excursion
 438         (goto-char (point-min))
 439         (when (search-forward (car hlcfg0) nil t)
 440           (unless (overlays-at (match-beginning 0))
 441             (setq ov (make-overlay (match-beginning 0)
 442                                    (match-end 0))))
 443           (cond ((eq (cdr hlcfg0) 'children)
 444                  (org-show-children)
 445                  (message "CHILDREN")
 446                  (overlay-put ov 'status 'children))
 447                 ((eq (cdr hlcfg0) 'branches)
 448                  (show-branches)
 449                  (message "BRANCHES")
 450                  (overlay-put ov 'status 'branches))))))
 451     (goto-char pos)
 452     (if org-toc-follow-mode (org-toc-goto))
 453     (message "Last TOC configuration restored")
 454     (sit-for 1)
 455     (if org-toc-info-mode (org-toc-info))))
 456
 457 (defun org-toc-get-headlines-status ()
 458   "Return an alist of headlines and their associated folding
 459 status."
 460   (let (output ovs)
 461     (save-excursion
 462       (goto-char (point-min))
 463       (while (and (not (eobp))
 464                   (goto-char (next-overlay-change (point))))
 465         (when (looking-at org-outline-regexp-bol)
 466           (add-to-list
 467            'output
 468            (cons (buffer-substring-no-properties
 469                   (match-beginning 0)
 470                   (save-excursion
 471                     (end-of-line) (point)))
 472                  (overlay-get
 473                   (car (overlays-at (point))) 'status))))))
 474     ;; return an alist like (("* Headline" . 'status))
 475     output))
 476
 477 ;; In Org TOC buffer, hide headlines below the first level.
 478 (defun org-toc-help ()
 479   "Display a quick help message in the echo-area for `org-toc-mode'."
 480   (interactive)
 481   (let ((st-start 0)
 482         (help-message
 483          "\[space\]   show heading                     \[1-4\] hide headlines below this level
 484 \[TAB\]     jump to heading                  \[F\]   toggle follow mode (currently %s)
 485 \[return\]  jump and delete others windows   \[i\]   toggle info mode (currently %s)
 486 \[S-TAB\]   cycle subtree (in Org)           \[S\]   toggle show subtree mode (currently %s)
 487 \[C-S-TAB\] global cycle (in Org)            \[r\]   toggle recenter mode (currently %s)
 488 \[:\]       cycle subtree (in TOC)           \[c\]   toggle column view (currently %s)
 489 \[n/p\]     next/previous heading            \[s\]   save TOC configuration
 490 \[f/b\]     next/previous heading of same level
 491 \[q\]       quit the TOC                     \[g\]   restore last TOC configuration"))
 492     (while (string-match "\\[[^]]+\\]" help-message st-start)
 493       (add-text-properties (match-beginning 0)
 494                            (match-end 0) '(face bold) help-message)
 495       (setq st-start (match-end 0)))
 496   (message help-message
 497     (if org-toc-follow-mode "on" "off")
 498     (if org-toc-info-mode "on" "off")
 499     (if org-toc-show-subtree-mode "on" "off")
 500     (if org-toc-recenter-mode (format "on, line %s" org-toc-recenter) "off")
 501     (if org-toc-columns-shown "on" "off"))))
 502
 503 \f
 504 ;;;;##########################################################################
 505 ;;;;  User Options, Variables
 506 ;;;;##########################################################################
 507
 508 ;;; org-toc.el ends here