1 ;;; outline-magic.el --- outline mode extensions for Emacs
3 ;; Copyright (C) 2002 Carsten Dominik <dominik@science.uva.nl>
5 ;; Maintainer: Carsten Dominik <dominik@science.uva.nl>
9 ;; This file is not part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
28 ;; This file implements extensions for outline(-minor)-mode.
30 ;; - VISIBILITY CYCLING: A *single* command to replace the many
31 ;; outline commands for showing and hiding parts of a document.
33 ;; - STRUCTURE EDITING: Promotion, demotion and transposition of subtrees.
38 ;; Byte-compile outline-magic.el, put it on the load path and copy the
39 ;; following into .emacs (adapting keybindings to your own preferences)
41 ;; (add-hook 'outline-mode-hook
43 ;; (require 'outline-cycle)))
45 ;; (add-hook 'outline-minor-mode-hook
47 ;; (require 'outline-magic)
48 ;; (define-key outline-minor-mode-map [(f10)] 'outline-cycle)))
56 ;; The command `outline-cycle' changes the visibility of text and headings
57 ;; in the buffer. Instead of using many different commands to show and
58 ;; hide buffer parts, `outline-cycle' cycles through the most important
59 ;; states of an outline buffer. In the major `outline-mode', it will be
60 ;; bound to the TAB key. In `outline-minor-mode', the user can choose a
61 ;; different keybinding. The action of the command depends on the current
64 ;; 1. When point is at the beginning of the buffer, `outline-cycle'
65 ;; cycles the entire buffer through 3 different states:
66 ;; - OVERVIEW: Only top-level headlines are shown.
67 ;; - CONTENTS: All headlines are shown, but no body text.
68 ;; - SHOW ALL: Everything is shown.
70 ;; 2. When point in a headline, `outline-cycle' cycles the subtree started
71 ;; by this line through the following states:
72 ;; - FOLDED: Only the headline is shown.
73 ;; - CHILDREN: The headline and its direct children are shown. From
74 ;; this state, you can move to one of the children and
76 ;; - SUBTREE: The entire subtree under the heading is shown.
78 ;; 3. At other positions, `outline-cycle' jumps back to the current heading.
79 ;; It can also be configured to emulate TAB at those positions, see
80 ;; the option `outline-cycle-emulate-tab'.
85 ;; Four commands are provided for structure editing. The commands work on
86 ;; the current subtree (the current headline plus all inferior ones). In
87 ;; addition to menu access, the commands are assigned to the four arrow
88 ;; keys pressed with a modifier (META by default) in the following way:
92 ;; promote <- | -> demote
96 ;; Thus, M-left will promote a subtree, M-up will move it up
97 ;; vertically throught the structure. Configure the variable
98 ;; `outline-structedit-modifiers' to use different modifier keys.
102 ;; The commands `outline-move-subtree-up' and `outline-move-subtree-down'
103 ;; move the entire current subtree (folded or not) past the next same-level
104 ;; heading in the given direction. The cursor moves with the subtree, so
105 ;; these commands can be used to "drag" a subtree to the wanted position.
106 ;; For example, `outline-move-subtree-down' applied with the cursor at the
107 ;; beginning of the "* Level 1b" line will change the tree like this:
109 ;; * Level 1a * Level 1a
110 ;; * Level 1b ===\ * Level 1c
111 ;; ** Level 2b ===/ * Level 1b
112 ;; * Level 1c ** Level 2b
114 ;; Promotion/Demotion
115 ;; - - - - - - - - - -
116 ;; The commands `outline-promote' and `outline-demote' change the current
117 ;; subtree to a different outline level - i.e. the level of all headings in
118 ;; the tree is decreased or increased. For example, `outline-demote'
119 ;; applied with the cursor at the beginning of the "* Level 1b" line will
120 ;; change the tree like this:
122 ;; * Level 1a * Level 1a
123 ;; * Level 1b ===\ ** Level 1b
124 ;; ** Level 2b ===/ *** Level 2
125 ;; * Level 1c * Level 1c
127 ;; The reverse operation is `outline-promote'. Note that the scope of
128 ;; "current subtree" may be changed after a promotion. To change all
129 ;; headlines in a region, use transient-mark-mode and apply the command to
132 ;; NOTE: Promotion/Demotion in complex outline setups
133 ;; - - - - - - - - - - - - - - - - - - - - - - - - - -
134 ;; Promotion/demotion works easily in a simple outline setup where the
135 ;; indicator of headings is just a polymer of a single character (e.g. "*"
136 ;; in the default outline mode). It can also work in more complicated
137 ;; setups. For example, in LaTeX-mode, sections can be promoted to
138 ;; chapters and vice versa. However, the outline setup for the mode must
139 ;; meet two requirements:
141 ;; 1. `outline-regexp' must match the full text which has to be changed
142 ;; during promotion/demotion. E.g. for LaTeX, it must match "\chapter"
143 ;; and not just "\chap". Major modes like latex-mode, AUCTeX's
144 ;; latex-mode and texinfo-mode do this correctly.
146 ;; 2. The variable `outline-promotion-headings' must contain a sorted list
147 ;; of headings as matched by `outline-regexp'. Each of the headings in
148 ;; `outline-promotion-headings' must be matched by `outline-regexp'.
149 ;; `outline-regexp' may match additional things - those matches will be
150 ;; ignored by the promotion commands. If a mode has multiple sets of
151 ;; sectioning commands (for example the texinfo-mode with
152 ;; chapter...subsubsection and unnumbered...unnumberedsubsubsec), the
153 ;; different sets can all be listed in the same list, but must be
154 ;; separated by nil elements to avoid "promotion" accross sets.
157 ;; (add-hook 'latex-mode-hook ; or 'LaTeX-mode-hook for AUCTeX
159 ;; (setq outline-promotion-headings
160 ;; '("\\chapter" "\\section" "\\subsection"
161 ;; "\\subsubsection" "\\paragraph" "\\subparagraph"))))
163 ;; (add-hook 'texinfo-mode-hook
165 ;; (setq outline-promotion-headings
166 ;; '("@chapter" "@section" "@subsection" "@subsubsection" nil
167 ;; "@unnumbered" "@unnumberedsec" "@unnumberedsubsec"
168 ;; "@unnumberedsubsubsec" nil
169 ;; "@appendix" "@appendixsec" "@appendixsubsec"
170 ;; "@appendixsubsubsec" nil
171 ;; "@chapheading" "@heading" "@subheading" "@subsubheading"))))
173 ;; If people find this useful enough, maybe the maintainers of the
174 ;; modes can be persuaded to set `outline-promotion-headings'
175 ;; already as part of the mode setup.
179 ;; outline-magic was developed to work with the new outline.el
180 ;; implementation which uses text properties instead of selective display.
181 ;; If you are using XEmacs which still has the old implementation, most
182 ;; commands will work fine. However, structure editing commands will
183 ;; require all relevant headlines to be visible.
187 ;; - Before first header now works as at beginning of file
188 ;; - Two levels are shown for contents.
194 ;;; Visibility cycling
196 (defcustom outline-cycle-emulate-tab nil
197 "Where should `outline-cycle' emulate TAB.
199 white Only in completely white lines
200 t Everywhere except in headlines"
202 :type '(choice (const :tag "Never" nil)
203 (const :tag "Only in completely white lines" white)
204 (const :tag "Everywhere except in headlines" t)
207 (defvar outline-promotion-headings nil
208 "A sorted list of headings used for promotion/demotion commands.
209 Set this to a list of headings as they are matched by `outline-regexp',
210 top-level heading first. If a mode or document needs several sets of
211 outline headings (for example numbered and unnumbered sections), list
212 them set by set, separated by a nil element. See the example for
213 `texinfo-mode' in the file commentary.")
214 (make-variable-buffer-local 'outline-promotion-headings)
216 (defun outline-cycle (&optional arg)
217 "Visibility cycling for outline(-minor)-mode.
219 - When point is at the beginning of the buffer, or when called with a
220 C-u prefix argument, rotate the entire buffer through 3 states:
221 1. OVERVIEW: Show only top-level headlines.
222 2. CONTENTS: Show all headlines of all levels, but no body text.
223 3. SHOW ALL: Show everything.
225 - When point is at the beginning of a headline, rotate the subtree started
226 by this line through 3 different states:
227 1. FOLDED: Only the main headline is shown.
228 2. CHILDREN: The main headline and the direct children are shown. From
229 this state, you can move to one of the children and
231 3. SUBTREE: Show the entire subtree, including body text.
233 - When point is not at the beginning of a headline, execute
234 `indent-relative', like TAB normally does."
236 (setq deactivate-mark t)
240 ; Run `outline-cycle' as if at the top of the buffer.
242 (goto-char (point-min))
243 (outline-cycle nil)))
247 ((or (bobp) ;; Beginning of buffer: Global cycling
252 (outline-back-to-heading)
258 ((eq last-command 'outline-cycle-overview)
259 ;; We just created the overview - now do table of contents
260 ;; This can be slow in very large buffers, so indicate action
261 (message "CONTENTS...")
263 ;; Visit all headings and show their offspring
264 (goto-char (point-max))
266 (while (and (progn (condition-case nil
267 (outline-previous-visible-heading 1)
268 (error (goto-char (point-min))))
270 (looking-at outline-regexp))
272 (if (bobp) (throw 'exit nil))))
273 (message "CONTENTS...done"))
274 (setq this-command 'outline-cycle-toc))
275 ((eq last-command 'outline-cycle-toc)
276 ;; We just showed the table of contents - now show everything
279 (setq this-command 'outline-cycle-showall))
281 ;; Default action: go to overview
282 ;; FIX-ME: variable sublevel here (for wikipedia for example):
285 (setq this-command 'outline-cycle-overview))))
287 ((save-excursion (beginning-of-line 1) (looking-at outline-regexp))
288 ;; At a heading: rotate between three different views
289 (outline-back-to-heading)
290 (let ((goal-column 0) beg eoh eol eos)
291 ;; First, some boundaries
293 (outline-back-to-heading) (setq beg (point))
294 (save-excursion (outline-next-line) (setq eol (point)))
295 (outline-end-of-heading) (setq eoh (point))
296 (outline-end-of-subtree) (setq eos (point)))
297 ;; Find out what to do next and set `this-command'
300 ;; Nothing is hidden behind this heading
301 (message "EMPTY ENTRY"))
303 ;; Entire subtree is hidden in one line: open it
307 (setq this-command 'outline-cycle-children))
308 ((eq last-command 'outline-cycle-children)
309 ;; We just showed the children, now show everything.
313 ;; Default action: hide the subtree.
315 (message "FOLDED")))))
318 ((outline-cycle-emulate-tab)
322 ;; Not at a headline: Do indent-relative
323 (outline-back-to-heading))))))
325 (defun outline-cycle-emulate-tab ()
326 "Check if TAB should be emulated at the current position."
327 ;; This is called after the check for point in a headline,
328 ;; so we can assume we are not in a headline
329 (if (and (eq outline-cycle-emulate-tab 'white)
331 (beginning-of-line 1) (looking-at "[ \t]+$")))
333 outline-cycle-emulate-tab))
335 (defun outline-next-line ()
336 "Forward line, but mover over invisible line ends.
337 Essentially a much simplified version of `next-line'."
339 (beginning-of-line 2)
340 (while (and (not (eobp))
341 (get-char-property (1- (point)) 'invisible))
342 (beginning-of-line 2)))
344 ;;; Vertical tree motion
346 (defun outline-move-subtree-up (&optional arg)
347 "Move the currrent subtree up past ARG headlines of the same level."
349 (outline-move-subtree-down (- arg)))
351 (defun outline-move-subtree-down (&optional arg)
352 "Move the currrent subtree down past ARG headlines of the same level."
354 (let ((re (concat "^" outline-regexp))
355 (movfunc (if (> arg 0) 'outline-get-next-sibling
356 'outline-get-last-sibling))
357 (ins-point (make-marker))
361 (outline-back-to-heading)
363 (outline-end-of-subtree)
364 (if (= (char-after) ?\n) (forward-char 1))
366 ;; Find insertion point, with error handling
369 (or (funcall movfunc)
370 (progn (goto-char beg)
371 (error "Cannot move past superior level")))
374 ;; Moving forward - still need to move over subtree
375 (progn (outline-end-of-subtree)
376 (if (= (char-after) ?\n) (forward-char 1))))
377 (move-marker ins-point (point))
378 (setq txt (buffer-substring beg end))
379 (delete-region beg end)
381 (goto-char ins-point)
382 (move-marker ins-point nil)))
384 ;;; Promotion and Demotion
386 (defun outline-promote (&optional arg)
387 "Decrease the level of an outline-structure by ARG levels.
388 When the region is active in transient-mark-mode, all headlines in the
389 region are changed. Otherwise the current subtree is targeted. Note that
390 after each application of the command the scope of \"current subtree\"
393 (outline-change-level (- arg)))
396 (defun outline-demote (&optional arg)
397 "Increase the level of an outline-structure by ARG levels.
398 When the region is active in transient-mark-mode, all headlines in the
399 region are changed. Otherwise the current subtree is targeted. Note that
400 after each application of the command the scope of \"current subtree\"
403 (outline-change-level arg))
405 (defun outline-change-level (delta)
406 "Workhorse for `outline-demote' and `outline-promote'."
407 (let* ((headlist (outline-headings-list))
408 (atom (outline-headings-atom headlist))
409 (re (concat "^" outline-regexp))
410 (transmode (and transient-mark-mode mark-active))
413 ;; Find the boundaries for this operation
416 (setq beg (min (point) (mark))
417 end (max (point) (mark)))
418 (outline-back-to-heading)
420 (outline-end-of-heading)
421 (outline-end-of-subtree)
423 (setq beg (move-marker (make-marker) beg)
424 end (move-marker (make-marker) end))
426 (let (head newhead level newlevel static)
428 ;; First a dry run to test if there is any trouble ahead.
430 (while (re-search-forward re end t)
431 (outline-change-heading headlist delta atom 'test))
433 ;; Now really do replace the headings
435 (while (re-search-forward re end t)
436 (outline-change-heading headlist delta atom))))))
438 (defun outline-headings-list ()
439 "Return a list of relevant headings, either a user/mode defined
440 list, or an alist derived from scanning the buffer."
443 (outline-promotion-headings
444 ;; configured by the user or the mode
445 (setq headlist outline-promotion-headings))
447 ((and (eq major-mode 'outline-mode) (string= outline-regexp "[*\^L]+"))
448 ;; default outline mode with original regexp
449 ;; this need special treatment because of the \f in the regexp
450 (setq headlist '(("*" . 1) ("**" . 2)))) ; will be extrapolated
452 (t ;; Check if the buffer contains a complete set of headings
453 (let ((re (concat "^" outline-regexp)) head level)
455 (goto-char (point-min))
456 (while (re-search-forward re nil t)
458 (beginning-of-line 1)
459 (setq head (outline-cleanup-match (match-string 0))
460 level (funcall outline-level))
461 (add-to-list 'headlist (cons head level))))))
462 ;; Check for uniqueness of levels in the list
463 (let* ((hl headlist) entry level seen nonunique)
464 (while (setq entry (car hl))
467 (if (and (not (outline-static-level-p level))
469 ;; We have two entries for the same level.
470 (add-to-list 'nonunique level))
471 (add-to-list 'seen level))
473 (error "Cannot promote/demote: non-unique headings at level %s\nYou may want to configure `outline-promotion-headings'."
474 (mapconcat 'int-to-string nonunique ","))))))
475 ;; OK, return the list
478 (defun outline-change-heading (headlist delta atom &optional test)
479 "Change heading just matched by `outline-regexp' by DELTA levels.
480 HEADLIST can be either an alist ((\"outline-match\" . level)...) or a
481 straight list like `outline-promotion-headings'. ATOM is a character
482 if all headlines are composed of a single character.
483 If TEST is non-nil, just prepare the change and error if there are problems.
484 TEST nil means, really replace old heading with new one."
485 (let* ((head (outline-cleanup-match (match-string 0)))
486 (level (save-excursion
487 (beginning-of-line 1)
488 (funcall outline-level)))
489 (newhead ; compute the new head
492 ((outline-static-level-p level) t)
493 ((null headlist) nil)
494 ((consp (car headlist))
495 ;; The headlist is an association list
496 (or (car (rassoc (+ delta level) headlist))
498 (> (+ delta level) 0)
499 (make-string (+ delta level) atom))))
501 ;; The headlist is a straight list - grab the correct element.
502 (let* ((l (length headlist))
503 (n1 (- l (length (member head headlist)))) ; index old
504 (n2 (+ delta n1))) ; index new
507 ((= n1 l) nil) ; head not found
508 ((< n2 0) nil) ; newlevel too low
509 ((>= n2 l) nil) ; newlevel too high
510 ((let* ((tail (nthcdr (min n1 n2) headlist))
511 (nilpos (- (length tail) (length (memq nil tail)))))
512 (< nilpos delta)) ; nil element between old and new
514 (t (nth n2 headlist)))))))) ; OK, we have a match!
516 (error "Cannot shift level %d heading \"%s\" to level %d"
517 level head (+ level delta)))
518 (if (and (not test) (stringp newhead))
520 (beginning-of-line 1)
521 (or (looking-at (concat "[ \t]*\\(" (regexp-quote head) "\\)"))
522 (error "Please contact maintainer"))
523 (replace-match newhead t t nil 1)))))
525 (defun outline-headings-atom (headlist)
526 "Use the list created by `outline-headings-list' and check if all
527 headings are polymers of a single character, e.g. \"*\".
528 If yes, return this character."
529 (if (consp (car headlist))
530 ;; this is an alist - it makes sense to check for atomic structure
531 (let ((re (concat "\\`"
532 (regexp-quote (substring (car (car headlist)) 0 1))
534 (if (not (delq nil (mapcar (lambda (x) (not (string-match re (car x))))
536 (string-to-char (car (car headlist)))))))
538 (defun outline-cleanup-match (s)
539 "Remove text properties and start/end whitespace from a string."
540 (set-text-properties 1 (length s) nil s)
542 (if (string-match "^[ \t]+" s) (setq s (replace-match "" t t s)))
543 (if (string-match "[ \t]+$" s) (setq s (replace-match "" t t s))))
546 (defun outline-static-level-p (level)
547 "Test if a level should not be changed by level promotion/demotion."
552 (defcustom outline-structedit-modifiers '(meta)
553 "List of modifiers for outline structure editing with the arrow keys."
555 :type '(repeat symbol))
557 (define-key outline-mode-map [(tab)] 'outline-cycle)
558 (let ((keys '((left . outline-promote)
559 (right . outline-demote)
560 (up . outline-move-subtree-up)
561 (down . outline-move-subtree-down)))
563 (while (setq key (pop keys))
564 (apply 'define-key outline-mode-map
566 (vector (append outline-structedit-modifiers (list (car key))))
571 (define-key outline-mode-menu-bar-map [headings outline-move-subtree-down]
572 '("Move subtree down" . outline-move-subtree-down))
573 (define-key outline-mode-menu-bar-map [headings outline-move-subtree-up]
574 '("Move subtree up" . outline-move-subtree-up))
575 (define-key outline-mode-menu-bar-map [headings outline-demote]
576 '("Demote by 1 level" . outline-demote))
577 (define-key outline-mode-menu-bar-map [headings outline-promote]
578 '("Promote by 1 level" . outline-promote))
579 (define-key outline-mode-menu-bar-map [show outline-cycle]
580 '("Rotate visibility" . outline-cycle))
581 (define-key outline-mode-menu-bar-map [hide outline-cycle]
582 '("Rotate visibility" . outline-cycle))
586 (provide 'outline-magic)
588 ;;; outline-magic.el ends here