Replace org-mode-p with usual (eq major-mode 'org-mode) check
[org-mode.git] / contrib / lisp / org-toc.el
1 ;;; org-toc.el --- Table of contents for Org-mode buffer
2
3 ;; Copyright 2007-2011 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