contrib/lisp/org-toc.el

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