contrib/lisp/org-toc.el

   1 ;;; org-toc.el --- Table of contents for Org-mode buffer
   2
   3 ;; Copyright 2007-2013 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 "f" 'org-toc-forward)
 124 (define-key org-toc-mode-map "b" 'org-toc-back)
 125 (define-key org-toc-mode-map [(left)] 'org-toc-back)
 126 (define-key org-toc-mode-map [(right)] 'org-toc-forward)
 127 (define-key org-toc-mode-map [(up)] 'org-toc-previous)
 128 (define-key org-toc-mode-map [(down)] 'org-toc-next)
 129 (define-key org-toc-mode-map "1" (lambda() (interactive) (org-toc-show 1 (point))))
 130 (define-key org-toc-mode-map "2" (lambda() (interactive) (org-toc-show 2 (point))))
 131 (define-key org-toc-mode-map "3" (lambda() (interactive) (org-toc-show 3 (point))))
 132 (define-key org-toc-mode-map "4" (lambda() (interactive) (org-toc-show 4 (point))))
 133 (define-key org-toc-mode-map " " 'org-toc-goto)
 134 (define-key org-toc-mode-map "q" 'org-toc-quit)
 135 (define-key org-toc-mode-map "x" 'org-toc-quit)
 136 ;; go to the location and stay in the base buffer
 137 (define-key org-toc-mode-map [(tab)] 'org-toc-jump)
 138 (define-key org-toc-mode-map "v" 'org-toc-jump)
 139 ;; go to the location and delete other windows
 140 (define-key org-toc-mode-map [(return)]
 141   (lambda() (interactive) (org-toc-jump t)))
 142
 143 ;; special keys
 144 (define-key org-toc-mode-map "c" 'org-toc-columns)
 145 (define-key org-toc-mode-map "?" 'org-toc-help)
 146 (define-key org-toc-mode-map ":" 'org-toc-cycle-subtree)
 147 (define-key org-toc-mode-map "\C-c\C-o" 'org-open-at-point)
 148 ;; global cycling in the base buffer
 149 (define-key org-toc-mode-map (kbd "C-S-<iso-lefttab>")
 150   'org-toc-cycle-base-buffer)
 151 ;; subtree cycling in the base buffer
 152 (define-key org-toc-mode-map [(control tab)]
 153   (lambda() (interactive) (org-toc-goto nil t)))
 154
 155 ;;; Toggle functions:
 156 (defun org-toc-follow-mode ()
 157   "Toggle follow mode in a `org-toc-mode' buffer."
 158   (interactive)
 159   (setq org-toc-follow-mode (not org-toc-follow-mode))
 160   (message "Follow mode is %s"
 161            (if org-toc-follow-mode "on" "off")))
 162
 163 (defun org-toc-info-mode ()
 164   "Toggle info mode in a `org-toc-mode' buffer."
 165   (interactive)
 166   (setq org-toc-info-mode (not org-toc-info-mode))
 167   (message "Info mode is %s"
 168            (if org-toc-info-mode "on" "off")))
 169
 170 (defun org-toc-show-subtree-mode ()
 171   "Toggle show subtree mode in a `org-toc-mode' buffer."
 172   (interactive)
 173   (setq org-toc-show-subtree-mode (not org-toc-show-subtree-mode))
 174   (message "Show subtree mode is %s"
 175            (if org-toc-show-subtree-mode "on" "off")))
 176
 177 (defun org-toc-recenter-mode (&optional line)
 178   "Toggle recenter mode in a `org-toc-mode' buffer. If LINE is
 179 specified, then make `org-toc-recenter' use this value."
 180   (interactive "P")
 181   (setq org-toc-recenter-mode (not org-toc-recenter-mode))
 182   (when (numberp line)
 183     (setq org-toc-recenter-mode t)
 184     (setq org-toc-recenter line))
 185   (message "Recenter mode is %s"
 186            (if org-toc-recenter-mode
 187                (format "on, line %d" org-toc-recenter) "off")))
 188
 189 (defun org-toc-cycle-subtree ()
 190   "Locally cycle a headline through two states: 'children and
 191 'folded"
 192   (interactive)
 193   (let ((beg (point))
 194         (end (save-excursion (end-of-line) (point)))
 195         (ov (car (overlays-at (point))))
 196         status)
 197     (if ov (setq status (overlay-get ov 'status))
 198       (setq ov (make-overlay beg end)))
 199     ;; change the folding status of this headline
 200     (cond ((or (null status) (eq status 'folded))
 201            (show-children)
 202            (message "CHILDREN")
 203            (overlay-put ov 'status 'children))
 204           ((eq status 'children)
 205            (show-branches)
 206            (message "BRANCHES")
 207            (overlay-put ov 'status 'branches))
 208           (t (hide-subtree)
 209              (message "FOLDED")
 210              (overlay-put ov 'status 'folded)))))
 211
 212 ;;; Main show function:
 213 ;; FIXME name this org-before-first-heading-p?
 214 (defun org-toc-before-first-heading-p ()
 215   "Before first heading?"
 216   (save-excursion
 217     (null (re-search-backward org-outline-regexp-bol nil t))))
 218
 219 ;;;###autoload
 220 (defun org-toc-show (&optional depth position)
 221   "Show the table of contents of the current Org-mode buffer."
 222   (interactive "P")
 223   (if (eq major-mode 'org-mode)
 224       (progn (setq org-toc-base-buffer (current-buffer))
 225              (setq org-toc-odd-levels-only org-odd-levels-only))
 226     (if (eq major-mode 'org-toc-mode)
 227         (org-pop-to-buffer-same-window org-toc-base-buffer)
 228       (error "Not in an Org buffer")))
 229   ;; create the new window display
 230   (let ((pos (or position
 231                  (save-excursion
 232                    (if (org-toc-before-first-heading-p)
 233                        (progn (re-search-forward org-outline-regexp-bol nil t)
 234                               (match-beginning 0))
 235                      (point))))))
 236     (setq org-toc-cycle-global-status org-cycle-global-status)
 237     (delete-other-windows)
 238     (and (get-buffer "*org-toc*") (kill-buffer "*org-toc*"))
 239     (switch-to-buffer-other-window
 240      (make-indirect-buffer org-toc-base-buffer "*org-toc*"))
 241     ;; make content before 1st headline invisible
 242     (goto-char (point-min))
 243     (let* ((beg (point-min))
 244            (end (and (re-search-forward "^\\*" nil t)
 245                      (1- (match-beginning 0))))
 246            (ov (make-overlay beg end))
 247            (help (format "Table of contents for %s (press ? for a quick help):\n"
 248                          (buffer-name org-toc-base-buffer))))
 249       (overlay-put ov 'invisible t)
 250       (overlay-put ov 'before-string help))
 251     ;; build the browsable TOC
 252     (cond (depth
 253            (let* ((dpth (if org-toc-odd-levels-only
 254                             (1- (* depth 2)) depth)))
 255              (org-content dpth)
 256              (setq org-toc-cycle-global-status
 257                    `(org-content ,dpth))))
 258            ((null org-toc-default-depth)
 259             (if (eq org-toc-cycle-global-status 'overview)
 260                 (progn (org-overview)
 261                        (setq org-cycle-global-status 'overview)
 262                        (run-hook-with-args 'org-cycle-hook 'overview))
 263               (progn (org-overview)
 264                      ;; FIXME org-content to show only headlines?
 265                      (org-content)
 266                      (setq org-cycle-global-status 'contents)
 267                      (run-hook-with-args 'org-cycle-hook 'contents))))
 268            (t (let* ((dpth0 org-toc-default-depth)
 269                      (dpth (if org-toc-odd-levels-only
 270                                (1- (* dpth0 2)) dpth0)))
 271                 (org-content dpth)
 272                 (setq org-toc-cycle-global-status
 273                       `(org-content ,dpth)))))
 274     (goto-char pos))
 275   (move-beginning-of-line nil)
 276   (org-toc-mode)
 277   (shrink-window-if-larger-than-buffer)
 278   (setq buffer-read-only t))
 279
 280 ;;; Navigation functions:
 281 (defun org-toc-goto (&optional jump cycle)
 282   "From Org TOC buffer, follow the targeted subtree in the Org window.
 283 If JUMP is non-nil, go to the base buffer.
 284 If JUMP is 'delete, go to the base buffer and delete other windows.
 285 If CYCLE is non-nil, cycle the targeted subtree in the Org window."
 286   (interactive)
 287   (let ((pos (point))
 288         (toc-buf (current-buffer)))
 289     (switch-to-buffer-other-window org-toc-base-buffer)
 290     (goto-char pos)
 291     (if cycle (org-cycle)
 292       (progn (org-overview)
 293              (if org-toc-show-subtree-mode
 294                  (org-show-subtree)
 295                (org-show-entry))
 296              (org-show-context)))
 297     (if org-toc-recenter-mode
 298         (if (>= org-toc-recenter 1000) (recenter)
 299           (recenter org-toc-recenter)))
 300     (cond ((null jump)
 301            (switch-to-buffer-other-window toc-buf))
 302           ((eq jump 'delete)
 303            (delete-other-windows)))))
 304
 305 (defun org-toc-cycle-base-buffer ()
 306   "Call `org-cycle' with a prefix argument in the base buffer."
 307   (interactive)
 308   (switch-to-buffer-other-window org-toc-base-buffer)
 309   (org-cycle t)
 310   (other-window 1))
 311
 312 (defun org-toc-jump (&optional delete)
 313   "From Org TOC buffer, jump to the targeted subtree in the Org window.
 314 If DELETE is non-nil, delete other windows when in the Org buffer."
 315   (interactive "P")
 316   (if delete (org-toc-goto 'delete)
 317     (org-toc-goto t)))
 318
 319 (defun org-toc-previous ()
 320   "Go to the previous headline of the TOC."
 321   (interactive)
 322   (if (save-excursion
 323           (beginning-of-line)
 324           (re-search-backward "^\\*" nil t))
 325     (outline-previous-visible-heading 1)
 326     (message "No previous heading"))
 327   (if org-toc-info-mode (org-toc-info))
 328   (if org-toc-follow-mode (org-toc-goto)))
 329
 330 (defun org-toc-next ()
 331   "Go to the next headline of the TOC."
 332   (interactive)
 333   (outline-next-visible-heading 1)
 334   (if org-toc-info-mode (org-toc-info))
 335   (if org-toc-follow-mode (org-toc-goto)))
 336
 337 (defun org-toc-forward ()
 338   "Go to the next headline at the same level in the TOC."
 339   (interactive)
 340   (condition-case nil
 341       (outline-forward-same-level 1)
 342     (error (message "No next headline at this level.")))
 343   (if org-toc-info-mode (org-toc-info))
 344   (if org-toc-follow-mode (org-toc-goto)))
 345
 346 (defun org-toc-back ()
 347   "Go to the previous headline at the same level in the TOC."
 348   (interactive)
 349   (condition-case nil
 350       (outline-backward-same-level 1)
 351     (error (message "No previous headline at this level.")))
 352   (if org-toc-info-mode (org-toc-info))
 353   (if org-toc-follow-mode (org-toc-goto)))
 354
 355 (defun org-toc-quit ()
 356   "Quit the current Org TOC buffer."
 357   (interactive)
 358   (kill-this-buffer)
 359   (other-window 1)
 360   (delete-other-windows))
 361
 362 ;;; Special functions:
 363 (defun org-toc-columns ()
 364   "Toggle columns view in the Org buffer from Org TOC."
 365   (interactive)
 366   (let ((indirect-buffer (current-buffer)))
 367     (org-pop-to-buffer-same-window org-toc-base-buffer)
 368     (if (not org-toc-columns-shown)
 369         (progn (org-columns)
 370                (setq org-toc-columns-shown t))
 371       (progn (org-columns-remove-overlays)
 372              (setq org-toc-columns-shown nil)))
 373     (org-pop-to-buffer-same-window indirect-buffer)))
 374
 375 (defun org-toc-info ()
 376   "Show properties of current subtree in the echo-area."
 377   (interactive)
 378   (let ((pos (point))
 379         (indirect-buffer (current-buffer))
 380         props prop msg)
 381     (org-pop-to-buffer-same-window org-toc-base-buffer)
 382     (goto-char pos)
 383     (setq props (org-entry-properties))
 384     (while (setq prop (pop props))
 385       (unless (or (equal (car prop) "COLUMNS")
 386                   (member (car prop) org-toc-info-exclude))
 387         (let ((p (car prop))
 388               (v (cdr prop)))
 389           (if (equal p "TAGS")
 390               (setq v (mapconcat 'identity (split-string v ":" t) " ")))
 391           (setq p (concat p ":"))
 392           (add-text-properties 0 (length p) '(face org-special-keyword) p)
 393           (setq msg (concat msg p " " v "  ")))))
 394     (org-pop-to-buffer-same-window indirect-buffer)
 395     (message msg)))
 396
 397 ;;; Store and restore TOC configuration:
 398 (defun org-toc-store-config ()
 399   "Store the current status of the tables of contents in
 400 `org-toc-config-alist'."
 401   (interactive)
 402   (let ((file (buffer-file-name org-toc-base-buffer))
 403         (pos (point))
 404         (hlcfg (org-toc-get-headlines-status)))
 405     (setq org-toc-config-alist
 406           (delete (assoc file org-toc-config-alist)
 407                   org-toc-config-alist))
 408     (add-to-list 'org-toc-config-alist
 409                  `(,file ,pos ,org-toc-cycle-global-status ,hlcfg))
 410     (message "TOC configuration saved: (%s)"
 411              (if (listp org-toc-cycle-global-status)
 412                  (concat "org-content "
 413                          (number-to-string
 414                           (cadr org-toc-cycle-global-status)))
 415                (symbol-name org-toc-cycle-global-status)))))
 416
 417 (defun org-toc-restore-config ()
 418   "Get the stored status in `org-toc-config-alist' and set the
 419 current table of contents to it."
 420   (interactive)
 421   (let* ((file (buffer-file-name org-toc-base-buffer))
 422          (conf (cdr (assoc file org-toc-config-alist)))
 423          (pos (car conf))
 424          (status (cadr conf))
 425          (hlcfg (caddr conf)) hlcfg0 ov)
 426     (cond ((listp status)
 427            (org-toc-show (cadr status) (point)))
 428           ((eq status 'overview)
 429            (org-overview)
 430            (setq org-cycle-global-status 'overview)
 431            (run-hook-with-args 'org-cycle-hook 'overview))
 432           (t
 433            (org-overview)
 434            (org-content)
 435            (setq org-cycle-global-status 'contents)
 436            (run-hook-with-args 'org-cycle-hook 'contents)))
 437     (while (setq hlcfg0 (pop hlcfg))
 438       (save-excursion
 439         (goto-char (point-min))
 440         (when (search-forward (car hlcfg0) nil t)
 441           (unless (overlays-at (match-beginning 0))
 442             (setq ov (make-overlay (match-beginning 0)
 443                                    (match-end 0))))
 444           (cond ((eq (cdr hlcfg0) 'children)
 445                  (show-children)
 446                  (message "CHILDREN")
 447                  (overlay-put ov 'status 'children))
 448                 ((eq (cdr hlcfg0) 'branches)
 449                  (show-branches)
 450                  (message "BRANCHES")
 451                  (overlay-put ov 'status 'branches))))))
 452     (goto-char pos)
 453     (if org-toc-follow-mode (org-toc-goto))
 454     (message "Last TOC configuration restored")
 455     (sit-for 1)
 456     (if org-toc-info-mode (org-toc-info))))
 457
 458 (defun org-toc-get-headlines-status ()
 459   "Return an alist of headlines and their associated folding
 460 status."
 461   (let (output ovs)
 462     (save-excursion
 463       (goto-char (point-min))
 464       (while (and (not (eobp))
 465                   (goto-char (next-overlay-change (point))))
 466         (when (looking-at org-outline-regexp-bol)
 467           (add-to-list
 468            'output
 469            (cons (buffer-substring-no-properties
 470                   (match-beginning 0)
 471                   (save-excursion
 472                     (end-of-line) (point)))
 473                  (overlay-get
 474                   (car (overlays-at (point))) 'status))))))
 475     ;; return an alist like (("* Headline" . 'status))
 476     output))
 477
 478 ;; In Org TOC buffer, hide headlines below the first level.
 479 (defun org-toc-help ()
 480   "Display a quick help message in the echo-area for `org-toc-mode'."
 481   (interactive)
 482   (let ((st-start 0)
 483         (help-message
 484          "\[space\]   show heading                     \[1-4\] hide headlines below this level
 485 \[TAB\]     jump to heading                  \[F\]   toggle follow mode (currently %s)
 486 \[return\]  jump and delete others windows   \[i\]   toggle info mode (currently %s)
 487 \[S-TAB\]   cycle subtree (in Org)           \[S\]   toggle show subtree mode (currently %s)
 488 \[C-S-TAB\] global cycle (in Org)            \[r\]   toggle recenter mode (currently %s)
 489 \[:\]       cycle subtree (in TOC)           \[c\]   toggle column view (currently %s)
 490 \[n/p\]     next/previous heading            \[s\]   save TOC configuration
 491 \[f/b\]     next/previous heading of same level
 492 \[q\]       quit the TOC                     \[g\]   restore last TOC configuration"))
 493     (while (string-match "\\[[^]]+\\]" help-message st-start)
 494       (add-text-properties (match-beginning 0)
 495                            (match-end 0) '(face bold) help-message)
 496       (setq st-start (match-end 0)))
 497   (message help-message
 498     (if org-toc-follow-mode "on" "off")
 499     (if org-toc-info-mode "on" "off")
 500     (if org-toc-show-subtree-mode "on" "off")
 501     (if org-toc-recenter-mode (format "on, line %s" org-toc-recenter) "off")
 502     (if org-toc-columns-shown "on" "off"))))
 503
 504 \f
 505 ;;;;##########################################################################
 506 ;;;;  User Options, Variables
 507 ;;;;##########################################################################
 508
 509 ;;; org-toc.el ends here