;;; org-toc.el --- Table of contents for Org-mode buffer
;; Copyright 2007 Bastien Guerry
;;
;; Author: Bastien Guerry <bzg AT altern DOT org>
;; Keywords: Org table of contents
;; Homepage: http://www.cognition.ens.fr/~guerry/u/org-toc.el
;; Version: 0.8
;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 3, or (at your option)
;; any later version.
;;
;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;; GNU General Public License for more details.
;;
;; You should have received a copy of the GNU General Public License
;; along with this program; if not, write to the Free Software
;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;; Commentary:
;; This library implements a browsable table of contents for Org files.
;; Put this file into your load-path and the following into your ~/.emacs:
;; (require 'org-toc)
;;; Code:
(provide 'org-toc)
(eval-when-compile
(require 'cl))
;;; Custom variables:
(defvar org-toc-base-buffer nil)
(defvar org-toc-columns-shown nil)
(defvar org-toc-odd-levels-only nil)
(defvar org-toc-config-alist nil)
(defvar org-toc-cycle-global-status nil)
(defalias 'org-show-table-of-contents 'org-toc-show)
(defgroup org-toc nil
"Options concerning the browsable table of contents of Org-mode."
:tag "Org TOC"
:group 'org)
(defcustom org-toc-default-depth 1
"Default depth when invoking `org-toc-show' without argument."
:group 'org-toc
:type '(choice
(const :tag "same as base buffer" nil)
(integer :tag "level")))
(defcustom org-toc-follow-mode nil
"Non-nil means navigating through the table of contents will
move the point in the Org buffer accordingly."
:group 'org-toc
:type 'boolean)
(defcustom org-toc-info-mode nil
"Non-nil means navigating through the table of contents will
show the properties for the current headline in the echo-area."
:group 'org-toc
:type 'boolean)
(defcustom org-toc-show-subtree-mode nil
"Non-nil means show subtree when going to headline or following
it while browsing the table of contents."
:group 'org-toc
:type '(choice
(const :tag "show subtree" t)
(const :tag "show entry" nil)))
(defcustom org-toc-recenter-mode t
"Non-nil means recenter the Org buffer when following the
headlines in the TOC buffer."
:group 'org-toc
:type 'boolean)
(defcustom org-toc-recenter 0
"Where to recenter the Org buffer when unfolding a subtree.
This variable is only used when `org-toc-recenter-mode' is set to
'custom. A value >=1000 will call recenter with no arg."
:group 'org-toc
:type 'integer)
(defcustom org-toc-info-exclude '("ALLTAGS")
"A list of excluded properties when displaying info in the
echo-area. The COLUMNS property is always exluded."
:group 'org-toc
:type 'lits)
;;; Org TOC mode:
(defvar org-toc-mode-map (make-sparse-keymap)
"Keymap for `org-toc-mode'.")
(defun org-toc-mode ()
"A major mode for browsing the table of contents of an Org buffer.
\\{org-toc-mode-map}"
(interactive)
(kill-all-local-variables)
(use-local-map org-toc-mode-map)
(setq mode-name "Org TOC")
(setq major-mode 'org-toc-mode))
;; toggle modes
(define-key org-toc-mode-map "f" 'org-toc-follow-mode)
(define-key org-toc-mode-map "S" 'org-toc-show-subtree-mode)
(define-key org-toc-mode-map "s" 'org-toc-store-config)
(define-key org-toc-mode-map "g" 'org-toc-restore-config)
(define-key org-toc-mode-map "i" 'org-toc-info-mode)
(define-key org-toc-mode-map "r" 'org-toc-recenter-mode)
;; navigation keys
(define-key org-toc-mode-map "p" 'org-toc-previous)
(define-key org-toc-mode-map "n" 'org-toc-next)
(define-key org-toc-mode-map [(left)] 'org-toc-previous)
(define-key org-toc-mode-map [(right)] 'org-toc-next)
(define-key org-toc-mode-map [(up)] 'org-toc-previous)
(define-key org-toc-mode-map [(down)] 'org-toc-next)
(define-key org-toc-mode-map "1" (lambda() (interactive) (org-toc-show 1 (point))))
(define-key org-toc-mode-map "2" (lambda() (interactive) (org-toc-show 2 (point))))
(define-key org-toc-mode-map "3" (lambda() (interactive) (org-toc-show 3 (point))))
(define-key org-toc-mode-map "4" (lambda() (interactive) (org-toc-show 4 (point))))
(define-key org-toc-mode-map " " 'org-toc-goto)
(define-key org-toc-mode-map "q" 'org-toc-quit)
(define-key org-toc-mode-map "x" 'org-toc-quit)
;; go to the location and stay in the base buffer
(define-key org-toc-mode-map [(tab)] 'org-toc-jump)
(define-key org-toc-mode-map "v" 'org-toc-jump)
;; go to the location and delete other windows
(define-key org-toc-mode-map [(return)]
(lambda() (interactive) (org-toc-jump t)))
;; special keys
(define-key org-toc-mode-map "c" 'org-toc-columns)
(define-key org-toc-mode-map "?" 'org-toc-help)
(define-key org-toc-mode-map ":" 'org-toc-cycle-subtree)
(define-key org-toc-mode-map "\C-c\C-o" 'org-open-at-point)
;; global cycling in the base buffer
(define-key org-toc-mode-map (kbd "C-S-<iso-lefttab>")
'org-toc-cycle-base-buffer)
;; subtree cycling in the base buffer
(define-key org-toc-mode-map [(control tab)]
(lambda() (interactive) (org-toc-goto nil t)))
;;; Toggle functions:
(defun org-toc-follow-mode ()
"Toggle follow mode in a `org-toc-mode' buffer."
(interactive)
(setq org-toc-follow-mode (not org-toc-follow-mode))
(message "Follow mode is %s"
(if org-toc-follow-mode "on" "off")))
(defun org-toc-info-mode ()
"Toggle info mode in a `org-toc-mode' buffer."
(interactive)
(setq org-toc-info-mode (not org-toc-info-mode))
(message "Info mode is %s"
(if org-toc-info-mode "on" "off")))
(defun org-toc-show-subtree-mode ()
"Toggle show subtree mode in a `org-toc-mode' buffer."
(interactive)
(setq org-toc-show-subtree-mode (not org-toc-show-subtree-mode))
(message "Show subtree mode is %s"
(if org-toc-show-subtree-mode "on" "off")))
(defun org-toc-recenter-mode (&optional line)
"Toggle recenter mode in a `org-toc-mode' buffer. If LINE is
specified, then make `org-toc-recenter' use this value."
(interactive "P")
(setq org-toc-recenter-mode (not org-toc-recenter-mode))
(when (numberp line)
(setq org-toc-recenter-mode t)
(setq org-toc-recenter line))
(message "Recenter mode is %s"
(if org-toc-recenter-mode
(format "on, line %d" org-toc-recenter) "off")))
(defun org-toc-cycle-subtree ()
"Locally cycle a headline through two states: 'children and
'folded"
(interactive)
(let ((beg (point))
(end (save-excursion (end-of-line) (point)))
(ov (car (overlays-at (point))))
status)
(if ov (setq status (overlay-get ov 'status))
(setq ov (make-overlay beg end)))
;; change the folding status of this headline
(cond ((or (null status) (eq status 'folded))
(show-children)
(message "CHILDREN")
(overlay-put ov 'status 'children))
((eq status 'children)
(show-branches)
(message "BRANCHES")
(overlay-put ov 'status 'branches))
(t (hide-subtree)
(message "FOLDED")
(overlay-put ov 'status 'folded)))))
;;; Main show function:
;; FIXME name this org-before-first-heading-p?
(defun org-toc-before-first-heading-p ()
"Before first heading?"
(save-excursion
(null (re-search-backward "^\\*+ " nil t))))
;;;###autoload
(defun org-toc-show (&optional depth position)
"Show the table of contents of the current Org-mode buffer."
(interactive "P")
(if (org-mode-p)
(progn (setq org-toc-base-buffer (current-buffer))
(setq org-toc-odd-levels-only org-odd-levels-only))
(if (eq major-mode 'org-toc-mode)
(switch-to-buffer org-toc-base-buffer)
(error "Not in an Org buffer")))
;; create the new window display
(let ((pos (or position
(save-excursion
(if (org-toc-before-first-heading-p)
(progn (re-search-forward "^\\*+ " nil t)
(match-beginning 0))
(point))))))
(setq org-toc-cycle-global-status org-cycle-global-status)
(delete-other-windows)
(and (get-buffer "*org-toc*") (kill-buffer "*org-toc*"))
(switch-to-buffer-other-window
(make-indirect-buffer org-toc-base-buffer "*org-toc*"))
;; make content before 1st headline invisible
(goto-char (point-min))
(let* ((beg (point-min))
(end (and (re-search-forward "^\\*" nil t)
(1- (match-beginning 0))))
(ov (make-overlay beg end))
(help (format "Table of contents for %s (press ? for a quick help):\n"
(buffer-name org-toc-base-buffer))))
(overlay-put ov 'invisible t)
(overlay-put ov 'before-string help))
;; build the browsable TOC
(cond (depth
(let* ((dpth (if org-toc-odd-levels-only
(1- (* depth 2)) depth)))
(org-content dpth)
(setq org-toc-cycle-global-status
`(org-content ,dpth))))
((null org-toc-default-depth)
(if (eq org-toc-cycle-global-status 'overview)
(progn (org-overview)
(setq org-cycle-global-status 'overview)
(run-hook-with-args 'org-cycle-hook 'overview))
(progn (org-overview)
;; FIXME org-content to show only headlines?
(org-content)
(setq org-cycle-global-status 'contents)
(run-hook-with-args 'org-cycle-hook 'contents))))
(t (let* ((dpth0 org-toc-default-depth)
(dpth (if org-toc-odd-levels-only
(1- (* dpth0 2)) dpth0)))
(org-content dpth)
(setq org-toc-cycle-global-status
`(org-content ,dpth)))))
(goto-char pos))
(move-beginning-of-line nil)
(org-toc-mode)
(shrink-window-if-larger-than-buffer)
(setq buffer-read-only t))
;;; Navigation functions:
(defun org-toc-goto (&optional jump cycle)
"From Org TOC buffer, follow the targeted subtree in the Org window.
If JUMP is non-nil, go to the base buffer.
If JUMP is 'delete, go to the base buffer and delete other windows.
If CYCLE is non-nil, cycle the targeted subtree in the Org window."
(interactive)
(let ((pos (point))
(toc-buf (current-buffer)))
(switch-to-buffer-other-window org-toc-base-buffer)
(goto-char pos)
(if cycle (org-cycle)
(progn (org-overview)
(if org-toc-show-subtree-mode
(org-show-subtree)
(org-show-entry))
(org-show-context)))
(if org-toc-recenter-mode
(if (>= org-toc-recenter 1000) (recenter)
(recenter org-toc-recenter)))
(cond ((null jump)
(switch-to-buffer-other-window toc-buf))
((eq jump 'delete)
(delete-other-windows)))))
(defun org-toc-cycle-base-buffer ()
"Call `org-cycle' with a prefix argument in the base buffer."
(interactive)
(switch-to-buffer-other-window org-toc-base-buffer)
(org-cycle t)
(other-window 1))
(defun org-toc-jump (&optional delete)
"From Org TOC buffer, jump to the targeted subtree in the Org window.
If DELETE is non-nil, delete other windows when in the Org buffer."
(interactive "P")
(if delete (org-toc-goto 'delete)
(org-toc-goto t)))
(defun org-toc-previous ()
"Go to the previous headline of the TOC."
(interactive)
(if (save-excursion
(beginning-of-line)
(re-search-backward "^\\*" nil t))
(outline-previous-visible-heading 1)
(message "No previous heading"))
(if org-toc-info-mode (org-toc-info))
(if org-toc-follow-mode (org-toc-goto)))
(defun org-toc-next ()
"Go to the next headline of the TOC."
(interactive)
(outline-next-visible-heading 1)
(if org-toc-info-mode (org-toc-info))
(if org-toc-follow-mode (org-toc-goto)))
(defun org-toc-quit ()
"Quit the current Org TOC buffer."
(interactive)
(kill-this-buffer)
(other-window 1)
(delete-other-windows))
;;; Special functions:
(defun org-toc-columns ()
"Toggle columns view in the Org buffer from Org TOC."
(interactive)
(let ((indirect-buffer (current-buffer)))
(switch-to-buffer org-toc-base-buffer)
(if (not org-toc-columns-shown)
(progn (org-columns)
(setq org-toc-columns-shown t))
(progn (org-columns-remove-overlays)
(setq org-toc-columns-shown nil)))
(switch-to-buffer indirect-buffer)))
(defun org-toc-info ()
"Show properties of current subtree in the echo-area."
(interactive)
(let ((pos (point))
(indirect-buffer (current-buffer))
props prop msg)
(switch-to-buffer org-toc-base-buffer)
(goto-char pos)
(setq props (org-entry-properties))
(while (setq prop (pop props))
(unless (or (equal (car prop) "COLUMNS")
(member (car prop) org-toc-info-exclude))
(let ((p (car prop))
(v (cdr prop)))
(if (equal p "TAGS")
(setq v (mapconcat 'identity (split-string v ":" t) " ")))
(setq p (concat p ":"))
(add-text-properties 0 (length p) '(face org-special-keyword) p)
(setq msg (concat msg p " " v " ")))))
(switch-to-buffer indirect-buffer)
(message msg)))
;;; Store and restore TOC configuration:
(defun org-toc-store-config ()
"Store the current status of the tables of contents in
`org-toc-config-alist'."
(interactive)
(let ((file (buffer-file-name org-toc-base-buffer))
(pos (point))
(hlcfg (org-toc-get-headlines-status)))
(setq org-toc-config-alist
(delete (assoc file org-toc-config-alist)
org-toc-config-alist))
(add-to-list 'org-toc-config-alist
`(,file ,pos ,org-toc-cycle-global-status ,hlcfg))
(message "TOC configuration saved: (%s)"
(if (listp org-toc-cycle-global-status)
(concat "org-content "
(number-to-string
(cadr org-toc-cycle-global-status)))
(symbol-name org-toc-cycle-global-status)))))
(defun org-toc-restore-config ()
"Get the stored status in `org-toc-config-alist' and set the
current table of contents to it."
(interactive)
(let* ((file (buffer-file-name org-toc-base-buffer))
(conf (cdr (assoc file org-toc-config-alist)))
(pos (car conf))
(status (cadr conf))
(hlcfg (caddr conf)) hlcfg0 ov)
(cond ((listp status)
(org-toc-show (cadr status) (point)))
((eq status 'overview)
(org-overview)
(setq org-cycle-global-status 'overview)
(run-hook-with-args 'org-cycle-hook 'overview))
(t
(org-overview)
(org-content)
(setq org-cycle-global-status 'contents)
(run-hook-with-args 'org-cycle-hook 'contents)))
(while (setq hlcfg0 (pop hlcfg))
(save-excursion
(goto-char (point-min))
(when (search-forward (car hlcfg0) nil t)
(unless (overlays-at (match-beginning 0))
(setq ov (make-overlay (match-beginning 0)
(match-end 0))))
(cond ((eq (cdr hlcfg0) 'children)
(show-children)
(message "CHILDREN")
(overlay-put ov 'status 'children))
((eq (cdr hlcfg0) 'branches)
(show-branches)
(message "BRANCHES")
(overlay-put ov 'status 'branches))))))
(goto-char pos)
(if org-toc-follow-mode (org-toc-goto))
(message "Last TOC configuration restored")
(sit-for 1)
(if org-toc-info-mode (org-toc-info))))
(defun org-toc-get-headlines-status ()
"Return an alist of headlines and their associated folding
status."
(let (output ovs)
(save-excursion
(goto-char (point-min))
(while (and (not (eobp))
(goto-char (next-overlay-change (point))))
(when (looking-at "^\\*+ ")
(add-to-list
'output
(cons (buffer-substring-no-properties
(match-beginning 0)
(save-excursion
(end-of-line) (point)))
(overlay-get
(car (overlays-at (point))) 'status))))))
;; return an alist like (("* Headline" . 'status))
output))
;; In Org TOC buffer, hide headlines below the first level.
(defun org-toc-help ()
"Display a quick help message in the echo-area for `org-toc-mode'."
(interactive)
(let ((st-start 0)
(help-message
"\[space\] show heading \[1-4\] hide headlines below this level
\[TAB\] jump to heading \[f\] toggle follow mode (currently %s)
\[return\] jump and delete others windows \[i\] toggle info mode (currently %s)
\[S-TAB\] cycle subtree (in Org) \[S\] toggle show subtree mode (currently %s)
\[C-S-TAB\] global cycle (in Org) \[r\] toggle recenter mode (currently %s)
\[:\] cycle subtree (in TOC) \[c\] toggle column view (currently %s)
\[n/p\] next/previous heading \[s\] save TOC configuration
\[q\] quit the TOC \[g\] restore last TOC configuration"))
(while (string-match "\\[[^]]+\\]" help-message st-start)
(add-text-properties (match-beginning 0)
(match-end 0) '(face bold) help-message)
(setq st-start (match-end 0)))
(message help-message
(if org-toc-follow-mode "on" "off")
(if org-toc-info-mode "on" "off")
(if org-toc-show-subtree-mode "on" "off")
(if org-toc-recenter-mode (format "on, line %s" org-toc-recenter) "off")
(if org-toc-columns-shown "on" "off"))))
;;;;##########################################################################
;;;; User Options, Variables
;;;;##########################################################################
;;; org-toc.el ends here