diff options
Diffstat (limited to 'contrib/lisp/org-toc.el')
| -rw-r--r-- | contrib/lisp/org-toc.el | 488 |
1 files changed, 488 insertions, 0 deletions
diff --git a/contrib/lisp/org-toc.el b/contrib/lisp/org-toc.el new file mode 100644 index 0000000..3f37cb8 --- /dev/null +++ b/contrib/lisp/org-toc.el @@ -0,0 +1,488 @@ +;;; org-toc.el --- Table of contents for Org-mode buffer + +;; Copyright 2007-2012 Free Software Foundation, Inc. +;; +;; Author: Bastien Guerry <bzg AT gnu DOT org> +;; Keywords: Org table of contents +;; Homepage: http://www.cognition.ens.fr/~guerry/u/org-toc.el +;; Version: 0.8 + +;; This file is not part of GNU Emacs. + +;; 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 org-outline-regexp-bol nil t)))) + +;;;###autoload +(defun org-toc-show (&optional depth position) + "Show the table of contents of the current Org-mode buffer." + (interactive "P") + (if (eq major-mode 'org-mode) + (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) + (org-pop-to-buffer-same-window 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 org-outline-regexp-bol 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))) + (org-pop-to-buffer-same-window 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))) + (org-pop-to-buffer-same-window 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) + (org-pop-to-buffer-same-window 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 " "))))) + (org-pop-to-buffer-same-window 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 org-outline-regexp-bol) + (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 |