contrib/lisp/org-toc.el

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