nxml-outln.el 35.8 KB
Newer Older
Mark A. Hershberger's avatar
Mark A. Hershberger committed
1 2
;;; nxml-outln.el --- outline support for nXML mode

3
;; Copyright (C) 2004, 2007-2014 Free Software Foundation, Inc.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
4 5

;; Author: James Clark
6
;; Keywords: wp, hypermedia, languages, XML
Mark A. Hershberger's avatar
Mark A. Hershberger committed
7

Glenn Morris's avatar
Glenn Morris committed
8
;; This file is part of GNU Emacs.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
9

10
;; GNU Emacs is free software: you can redistribute it and/or modify
Glenn Morris's avatar
Glenn Morris committed
11
;; it under the terms of the GNU General Public License as published by
12 13
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
14

Glenn Morris's avatar
Glenn Morris committed
15 16 17 18 19 20
;; GNU Emacs 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
21
;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62

;;; Commentary:

;; A section can be in one of three states
;; 1. display normally; this displays each child section
;; according to its state; anything not part of child sections is also
;; displayed normally
;; 2. display just the title specially; child sections are not displayed
;; regardless of their state; anything not part of child sections is
;; not displayed
;; 3. display the title specially and display child sections
;; according to their state; anything not part of the child section is
;; not displayed
;; The state of a section is determined by the value of the
;; nxml-outline-state text property of the < character that starts
;; the section.
;; For state 1 the value is nil or absent.
;; For state 2 it is the symbol hide-children.
;; For state 3 it is t.
;; The special display is achieved by using overlays.  The overlays
;; are computed from the nxml-outline-state property by
;; `nxml-refresh-outline'. There overlays all have a category property
;; with an nxml-outline-display property with value t.
;;
;; For a section to be recognized as such, the following conditions must
;; be satisfied:
;; - its start-tag must occur at the start of a line (possibly indented)
;; - its local name must match `nxml-section-element-name-regexp'
;; - it must have a heading element; a heading element is an
;; element whose name matches `nxml-heading-element-name-regexp',
;; and that occurs as, or as a descendant of, the first child element
;; of the section
;;
;; XXX What happens if an nxml-outline-state property is attached to a
;; character that doesn't start a section element?
;;
;; An outlined section (an section with a non-nil nxml-outline-state
;; property) can be displayed in either single-line or multi-line
;; form.  Single-line form is used when the outline state is hide-children
;; or there are no child sections; multi-line form is used otherwise.
;; There are two flavors of single-line form: with children and without.
Paul Eggert's avatar
Paul Eggert committed
63
;; The with-children flavor is used when there are child sections.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84
;; Single line with children looks like
;;    <+section>A section title...</>
;; Single line without children looks like
;;    <-section>A section title...</>
;; Multi line looks likes
;;    <-section>A section title...
;;    [child sections displayed here]
;;    </-section>
;; The indent of an outlined section is computed relative to the
;; outermost containing outlined element.  The indent of the
;; outermost containing element comes from the non-outlined
;; indent of the section start-tag.

;;; Code:

(require 'xmltok)
(require 'nxml-util)
(require 'nxml-rap)

(defcustom nxml-section-element-name-regexp
  "article\\|\\(sub\\)*section\\|chapter\\|div\\|appendix\\|part\\|preface\\|reference\\|simplesect\\|bibliography\\|bibliodiv\\|glossary\\|glossdiv"
85
  "Regular expression matching the name of elements used as sections.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
86 87 88 89 90 91 92 93 94 95 96 97 98 99
An XML element is treated as a section if:

- its local name (that is, the name without the prefix) matches
this regexp;

- either its first child element or a descendant of that first child
element has a local name matching the variable
`nxml-heading-element-name-regexp'; and

- its start-tag occurs at the beginning of a line (possibly indented)."
  :group 'nxml
  :type 'regexp)

(defcustom nxml-heading-element-name-regexp "title\\|head"
100
  "Regular expression matching the name of elements used as headings.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
101 102 103 104 105 106 107
An XML element is only recognized as a heading if it occurs as or
within the first child of an element that is recognized as a section.
See the variable `nxml-section-element-name-regexp' for more details."
  :group 'nxml
  :type 'regexp)

(defcustom nxml-outline-child-indent 2
108
  "Indentation in an outline for child element relative to parent element."
Mark A. Hershberger's avatar
Mark A. Hershberger committed
109 110 111
  :group 'nxml
  :type 'integer)

112 113
(defface nxml-heading '((t :weight bold))
  "Face for the contents of abbreviated heading elements."
114
  :group 'nxml-faces)
Mark A. Hershberger's avatar
Mark A. Hershberger committed
115

116 117
(defface nxml-outline-indicator '((t))
  "Face for `+' or `-' before element names in outlines."
118
  :group 'nxml-faces)
Mark A. Hershberger's avatar
Mark A. Hershberger committed
119

120
(defface nxml-outline-active-indicator
121 122
  '((t :box t :inherit nxml-outline-indicator))
  "Face for clickable `+' or `-' before element names in outlines."
123
  :group 'nxml-faces)
Mark A. Hershberger's avatar
Mark A. Hershberger committed
124

125
(defface nxml-outline-ellipsis '((t :weight bold))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
126
  "Face used for `...' in outlines."
127
  :group 'nxml-faces)
Mark A. Hershberger's avatar
Mark A. Hershberger committed
128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151

(defvar nxml-heading-scan-distance 1000
  "Maximum distance from section to scan for heading.")

(defvar nxml-outline-prefix-map
  (let ((map (make-sparse-keymap)))
    (define-key map "\C-a" 'nxml-show-all)
    (define-key map "\C-t" 'nxml-hide-all-text-content)
    (define-key map "\C-r" 'nxml-refresh-outline)
    (define-key map "\C-c" 'nxml-hide-direct-text-content)
    (define-key map "\C-e" 'nxml-show-direct-text-content)
    (define-key map "\C-d" 'nxml-hide-subheadings)
    (define-key map "\C-s" 'nxml-show)
    (define-key map "\C-k" 'nxml-show-subheadings)
    (define-key map "\C-l" 'nxml-hide-text-content)
    (define-key map "\C-i" 'nxml-show-direct-subheadings)
    (define-key map "\C-o" 'nxml-hide-other)
    map))

;;; Commands for changing visibility

(defun nxml-show-all ()
  "Show all elements in the buffer normally."
  (interactive)
152
  (with-silent-modifications
Mark A. Hershberger's avatar
Mark A. Hershberger committed
153 154 155 156 157 158 159 160
    (remove-text-properties (point-min)
			    (point-max)
			    '(nxml-outline-state nil)))
  (nxml-outline-set-overlay nil (point-min) (point-max)))

(defun nxml-hide-all-text-content ()
  "Hide all text content in the buffer.
Anything that is in a section but is not a heading will be hidden.
161
The visibility of headings at any level will not be changed.  See the
Mark A. Hershberger's avatar
Mark A. Hershberger committed
162 163 164 165 166 167 168 169
variable `nxml-section-element-name-regexp' for more details on how to
customize which elements are recognized as sections and headings."
  (interactive)
  (nxml-transform-buffer-outline '((nil . t))))

(defun nxml-show-direct-text-content ()
  "Show the text content that is directly part of the section containing point.
Each subsection will be shown according to its individual state, which
170 171
will not be changed.  The section containing point is the innermost
section that contains the character following point.  See the variable
Mark A. Hershberger's avatar
Mark A. Hershberger committed
172 173 174 175 176 177 178 179 180 181 182
`nxml-section-element-name-regexp' for more details on how to
customize which elements are recognized as sections and headings."
  (interactive)
  (nxml-outline-pre-adjust-point)
  (nxml-set-outline-state (nxml-section-start-position) nil)
  (nxml-refresh-outline)
  (nxml-outline-adjust-point))

(defun nxml-show-direct-subheadings ()
  "Show the immediate subheadings of the section containing point.
The section containing point is the innermost section that contains
183
the character following point.  See the variable
Mark A. Hershberger's avatar
Mark A. Hershberger committed
184 185 186 187 188 189 190 191 192 193 194 195 196
`nxml-section-element-name-regexp' for more details on how to
customize which elements are recognized as sections and headings."
  (interactive)
  (let ((pos (nxml-section-start-position)))
    (when (eq (nxml-get-outline-state pos) 'hide-children)
      (nxml-set-outline-state pos t)))
  (nxml-refresh-outline)
  (nxml-outline-adjust-point))

(defun nxml-hide-direct-text-content ()
  "Hide the text content that is directly part of the section containing point.
The heading of the section will remain visible.  The state of
subsections will not be changed.  The section containing point is the
197
innermost section that contains the character following point.  See the
Mark A. Hershberger's avatar
Mark A. Hershberger committed
198 199 200 201 202 203 204 205 206 207 208 209 210 211
variable `nxml-section-element-name-regexp' for more details on how to
customize which elements are recognized as sections and headings."
  (interactive)
  (let ((pos (nxml-section-start-position)))
    (when (null (nxml-get-outline-state pos))
      (nxml-set-outline-state pos t)))
  (nxml-refresh-outline)
  (nxml-outline-adjust-point))

(defun nxml-hide-subheadings ()
  "Hide the subheadings that are part of the section containing point.
The text content will also be hidden, leaving only the heading of the
section itself visible.  The state of the subsections will also be
changed to hide their headings, so that \\[nxml-show-direct-text-content]
212
would show only the heading of the subsections.  The section containing
Mark A. Hershberger's avatar
Mark A. Hershberger committed
213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234
point is the innermost section that contains the character following
point.  See the variable `nxml-section-element-name-regexp' for more
details on how to customize which elements are recognized as sections
and headings."
  (interactive)
  (nxml-transform-subtree-outline '((nil . hide-children)
				    (t . hide-children))))

(defun nxml-show ()
  "Show the section containing point normally, without hiding anything.
This includes everything in the section at any level.  The section
containing point is the innermost section that contains the character
following point.  See the variable `nxml-section-element-name-regexp'
for more details on how to customize which elements are recognized as
sections and headings."
  (interactive)
  (nxml-transform-subtree-outline '((hide-children . nil)
				    (t . nil))))

(defun nxml-hide-text-content ()
  "Hide text content at all levels in the section containing point.
The section containing point is the innermost section that contains
235
the character following point.  See the variable
Mark A. Hershberger's avatar
Mark A. Hershberger committed
236 237 238 239 240 241 242 243 244
`nxml-section-element-name-regexp' for more details on how to
customize which elements are recognized as sections and headings."
  (interactive)
  (nxml-transform-subtree-outline '((nil . t))))

(defun nxml-show-subheadings ()
  "Show the subheadings at all levels of the section containing point.
The visibility of the text content at all levels in the section is not
changed.  The section containing point is the innermost section that
245
contains the character following point.  See the variable
Mark A. Hershberger's avatar
Mark A. Hershberger committed
246 247 248 249 250 251 252 253 254
`nxml-section-element-name-regexp' for more details on how to
customize which elements are recognized as sections and headings."
  (interactive)
  (nxml-transform-subtree-outline '((hide-children . t))))

(defun nxml-hide-other ()
  "Hide text content other than that directly in the section containing point.
Hide headings other than those of ancestors of that section and their
immediate subheadings.  The section containing point is the innermost
255
section that contains the character following point.  See the variable
Mark A. Hershberger's avatar
Mark A. Hershberger committed
256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348
`nxml-section-element-name-regexp' for more details on how to
customize which elements are recognized as sections and headings."
  (interactive)
  (let ((nxml-outline-state-transform-exceptions nil))
    (save-excursion
      (while (and (condition-case err
		      (nxml-back-to-section-start)
		    (nxml-outline-error (nxml-report-outline-error
					 "Couldn't find containing section: %s"
					 err)))
		  (progn
		    (when (and nxml-outline-state-transform-exceptions
			       (null (nxml-get-outline-state (point))))
		      (nxml-set-outline-state (point) t))
		    (setq nxml-outline-state-transform-exceptions
			  (cons (point)
				nxml-outline-state-transform-exceptions))
		    (< nxml-prolog-end (point))))
	(goto-char (1- (point)))))
    (nxml-transform-buffer-outline '((nil . hide-children)
				     (t . hide-children)))))

;; These variables are dynamically bound.  They are use to pass information to
;; nxml-section-tag-transform-outline-state.

(defvar nxml-outline-state-transform-exceptions nil)
(defvar nxml-target-section-pos nil)
(defvar nxml-depth-in-target-section nil)
(defvar nxml-outline-state-transform-alist nil)

(defun nxml-transform-buffer-outline (alist)
  (let ((nxml-target-section-pos nil)
	(nxml-depth-in-target-section 0)
	(nxml-outline-state-transform-alist alist)
	(nxml-outline-display-section-tag-function
	 'nxml-section-tag-transform-outline-state))
    (nxml-refresh-outline))
  (nxml-outline-adjust-point))

(defun nxml-transform-subtree-outline (alist)
  (let ((nxml-target-section-pos (nxml-section-start-position))
	(nxml-depth-in-target-section nil)
	(nxml-outline-state-transform-alist alist)
	(nxml-outline-display-section-tag-function
	 'nxml-section-tag-transform-outline-state))
    (nxml-refresh-outline))
  (nxml-outline-adjust-point))

(defun nxml-outline-pre-adjust-point ()
  (cond ((and (< (point-min) (point))
	      (get-char-property (1- (point)) 'invisible)
	      (not (get-char-property (point) 'invisible))
	      (let ((str (or (get-char-property (point) 'before-string)
			     (get-char-property (point) 'display))))
		(and (stringp str)
		     (>= (length str) 3)
		     (string= (substring str 0 3) "..."))))
	 ;; The ellipsis is a display property on a visible character
	 ;; following an invisible region. The position of the event
	 ;; will be the position before that character. We want to
	 ;; move point to the other side of the invisible region, i.e.
	 ;; following the last visible character before that invisible
	 ;; region.
	 (goto-char (previous-single-char-property-change (1- (point))
							  'invisible)))
	((and (< (point) (point-max))
	      (get-char-property (point) 'display)
	      (get-char-property (1+ (point)) 'invisible))
	 (goto-char (next-single-char-property-change (1+ (point))
						      'invisible)))
	((and (< (point) (point-max))
	      (get-char-property (point) 'invisible))
	 (goto-char (next-single-char-property-change (point)
						      'invisible)))))

(defun nxml-outline-adjust-point ()
  "Adjust point after showing or hiding elements."
  (when (and (get-char-property (point) 'invisible)
	     (< (point-min) (point))
	     (get-char-property (1- (point)) 'invisible))
    (goto-char (previous-single-char-property-change (point)
						     'invisible
						     nil
						     nxml-prolog-end))))

(defun nxml-transform-outline-state (section-start-pos)
  (let* ((old-state
	  (nxml-get-outline-state section-start-pos))
	 (change (assq old-state
		       nxml-outline-state-transform-alist)))
    (when change
      (nxml-set-outline-state section-start-pos
			      (cdr change)))))
349

Mark A. Hershberger's avatar
Mark A. Hershberger committed
350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372
(defun nxml-section-tag-transform-outline-state (startp
						 section-start-pos
						 &optional
						 heading-start-pos)
  (if (not startp)
      (setq nxml-depth-in-target-section
	    (and nxml-depth-in-target-section
		 (> nxml-depth-in-target-section 0)
		 (1- nxml-depth-in-target-section)))
    (cond (nxml-depth-in-target-section
	   (setq nxml-depth-in-target-section
		 (1+ nxml-depth-in-target-section)))
	  ((= section-start-pos nxml-target-section-pos)
	   (setq nxml-depth-in-target-section 0)))
    (when (and nxml-depth-in-target-section
	       (not (member section-start-pos
			    nxml-outline-state-transform-exceptions)))
      (nxml-transform-outline-state section-start-pos))))

(defun nxml-get-outline-state (pos)
  (get-text-property pos 'nxml-outline-state))

(defun nxml-set-outline-state (pos state)
373
  (with-silent-modifications
Mark A. Hershberger's avatar
Mark A. Hershberger committed
374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409
    (if state
	(put-text-property pos (1+ pos) 'nxml-outline-state state)
      (remove-text-properties pos (1+ pos) '(nxml-outline-state nil)))))

;;; Mouse interface

(defun nxml-mouse-show-direct-text-content (event)
  "Do the same as \\[nxml-show-direct-text-content] from a mouse click."
  (interactive "e")
  (and (nxml-mouse-set-point event)
       (nxml-show-direct-text-content)))

(defun nxml-mouse-hide-direct-text-content (event)
  "Do the same as \\[nxml-hide-direct-text-content] from a mouse click."
  (interactive "e")
  (and (nxml-mouse-set-point event)
       (nxml-hide-direct-text-content)))

(defun nxml-mouse-hide-subheadings (event)
  "Do the same as \\[nxml-hide-subheadings] from a mouse click."
  (interactive "e")
  (and (nxml-mouse-set-point event)
       (nxml-hide-subheadings)))

(defun nxml-mouse-show-direct-subheadings (event)
  "Do the same as \\[nxml-show-direct-subheadings] from a mouse click."
  (interactive "e")
  (and (nxml-mouse-set-point event)
       (nxml-show-direct-subheadings)))

(defun nxml-mouse-set-point (event)
  (mouse-set-point event)
  (and nxml-prolog-end t))

;; Display

Glenn Morris's avatar
Glenn Morris committed
410 411 412 413 414 415 416 417
(defsubst nxml-token-start-tag-p ()
  (or (eq xmltok-type 'start-tag)
      (eq xmltok-type 'partial-start-tag)))

(defsubst nxml-token-end-tag-p ()
  (or (eq xmltok-type 'end-tag)
      (eq xmltok-type 'partial-end-tag)))

418
(defun nxml-refresh-outline ()
Mark A. Hershberger's avatar
Mark A. Hershberger committed
419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437
  "Refresh the outline to correspond to the current XML element structure."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (kill-local-variable 'line-move-ignore-invisible)
    (make-local-variable 'line-move-ignore-invisible)
    (condition-case err
	(nxml-outline-display-rest nil nil nil)
      (nxml-outline-error
       (nxml-report-outline-error "Cannot display outline: %s" err)))))

(defvar nxml-outline-display-section-tag-function nil)

(defun nxml-outline-display-rest (outline-state start-tag-indent tag-qnames)
  "Display up to and including the end of the current element.
OUTLINE-STATE can be nil, t, hide-children.  START-TAG-INDENT is the
indent of the start-tag of the current element, or nil if no
containing element has a non-nil OUTLINE-STATE.  TAG-QNAMES is a list
of the qnames of the open elements.  Point is after the title content.
438
Leave point after the closing end-tag.  Return t if we had a
Mark A. Hershberger's avatar
Mark A. Hershberger committed
439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511
non-transparent child section."
  (let ((last-pos (point))
	(transparent-depth 0)
	;; don't want ellipsis before root element
	(had-children (not tag-qnames)))
    (while
	(cond ((not (nxml-section-tag-forward))
	       (if (null tag-qnames)
		   nil
		 (nxml-outline-error "missing end-tag %s"
				     (car tag-qnames))))
	      ;; section end-tag
	      ((nxml-token-end-tag-p)
	       (when nxml-outline-display-section-tag-function
		 (funcall nxml-outline-display-section-tag-function
			  nil
			  xmltok-start))
	       (let ((qname (xmltok-end-tag-qname)))
		 (unless tag-qnames
		   (nxml-outline-error "extra end-tag %s" qname))
		 (unless (string= (car tag-qnames) qname)
		   (nxml-outline-error "mismatched end-tag; expected %s, got %s"
				       (car tag-qnames)
				       qname)))
	       (cond ((> transparent-depth 0)
		      (setq transparent-depth (1- transparent-depth))
		      (setq tag-qnames (cdr tag-qnames))
		      t)
		     ((not outline-state)
		      (nxml-outline-set-overlay nil last-pos (point))
		      nil)
		     ((or (not had-children)
			  (eq outline-state 'hide-children))
		      (nxml-outline-display-single-line-end-tag last-pos)
		      nil)
		     (t
		      (nxml-outline-display-multi-line-end-tag last-pos
							       start-tag-indent)
		      nil)))
	      ;; section start-tag
	      (t
	       (let* ((qname (xmltok-start-tag-qname))
		      (section-start-pos xmltok-start)
		      (heading-start-pos
		       (and (or nxml-outline-display-section-tag-function
				(not (eq outline-state 'had-children))
				(not had-children))
			    (nxml-token-starts-line-p)
			    (nxml-heading-start-position))))
		 (when nxml-outline-display-section-tag-function
		   (funcall nxml-outline-display-section-tag-function
			    t
			    section-start-pos
			    heading-start-pos))
		 (setq tag-qnames (cons qname tag-qnames))
		 (if (or (not heading-start-pos)
			 (and (eq outline-state 'hide-children)
			      (setq had-children t)))
		     (setq transparent-depth (1+ transparent-depth))
		   (nxml-display-section last-pos
					 section-start-pos
					 heading-start-pos
					 start-tag-indent
					 outline-state
					 had-children
					 tag-qnames)
		   (setq had-children t)
		   (setq tag-qnames (cdr tag-qnames))
		   (setq last-pos (point))))
	       t)))
    had-children))

(defconst nxml-highlighted-less-than
512
  (propertize "<" 'face 'nxml-tag-delimiter))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
513 514

(defconst nxml-highlighted-greater-than
515
  (propertize ">" 'face 'nxml-tag-delimiter))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
516 517

(defconst nxml-highlighted-colon
518
  (propertize ":" 'face 'nxml-element-colon))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
519 520

(defconst nxml-highlighted-slash
521
  (propertize "/" 'face 'nxml-tag-slash))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
522 523

(defconst nxml-highlighted-ellipsis
524
  (propertize "..." 'face 'nxml-outline-ellipsis))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
525 526 527 528 529 530 531 532

(defconst nxml-highlighted-empty-end-tag
  (concat nxml-highlighted-ellipsis
	  nxml-highlighted-less-than
	  nxml-highlighted-slash
	  nxml-highlighted-greater-than))

(defconst nxml-highlighted-inactive-minus
533
  (propertize "-" 'face 'nxml-outline-indicator))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
534 535

(defconst nxml-highlighted-active-minus
536
  (propertize "-" 'face 'nxml-outline-active-indicator))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
537 538

(defconst nxml-highlighted-active-plus
539
  (propertize "+" 'face 'nxml-outline-active-indicator))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639

(defun nxml-display-section (last-pos
			     section-start-pos
			     heading-start-pos
			     parent-indent
			     parent-outline-state
			     had-children
			     tag-qnames)
  (let* ((section-start-pos-bol
	  (save-excursion
	    (goto-char section-start-pos)
	    (skip-chars-backward " \t")
	    (point)))
	 (outline-state (nxml-get-outline-state section-start-pos))
	 (newline-before-section-start-category
	  (cond ((and (not had-children) parent-outline-state)
		 'nxml-outline-display-ellipsis)
		 (outline-state 'nxml-outline-display-show)
		 (t nil))))
    (nxml-outline-set-overlay (and parent-outline-state
				   'nxml-outline-display-hide)
			      last-pos
			      (1- section-start-pos-bol)
			      nil
			      t)
    (if outline-state
      (let* ((indent (if parent-indent
			 (+ parent-indent nxml-outline-child-indent)
		       (save-excursion
			 (goto-char section-start-pos)
			 (current-column))))
	     start-tag-overlay)
	(nxml-outline-set-overlay newline-before-section-start-category
				  (1- section-start-pos-bol)
				  section-start-pos-bol
				  t)
	(nxml-outline-set-overlay 'nxml-outline-display-hide
				  section-start-pos-bol
				  section-start-pos)
	(setq start-tag-overlay
	    (nxml-outline-set-overlay 'nxml-outline-display-show
				      section-start-pos
				      (1+ section-start-pos)
				      t))
	;; line motion commands don't work right if start-tag-overlay
	;; covers multiple lines
	(nxml-outline-set-overlay 'nxml-outline-display-hide
				  (1+ section-start-pos)
				  heading-start-pos)
	(goto-char heading-start-pos)
	(nxml-end-of-heading)
	(nxml-outline-set-overlay 'nxml-outline-display-heading
				  heading-start-pos
				  (point))
	(let* ((had-children
		(nxml-outline-display-rest outline-state
					   indent
					   tag-qnames)))
	  (overlay-put start-tag-overlay
		       'display
		       (concat
			;; indent
			(make-string indent ?\ )
			;; <
			nxml-highlighted-less-than
			;; + or - indicator
			(cond ((not had-children)
			       nxml-highlighted-inactive-minus)
			      ((eq outline-state 'hide-children)
			       (overlay-put start-tag-overlay
					    'category
					    'nxml-outline-display-hiding-tag)
			       nxml-highlighted-active-plus)
			      (t
			       (overlay-put start-tag-overlay
					    'category
					    'nxml-outline-display-showing-tag)
			       nxml-highlighted-active-minus))
			;; qname
			(nxml-highlighted-qname (car tag-qnames))
			;; >
			nxml-highlighted-greater-than))))
      ;; outline-state nil
      (goto-char heading-start-pos)
      (nxml-end-of-heading)
      (nxml-outline-set-overlay newline-before-section-start-category
				(1- section-start-pos-bol)
				(point)
				t)
      (nxml-outline-display-rest outline-state
				 (and parent-indent
				      (+ parent-indent
					 nxml-outline-child-indent))
				 tag-qnames))))

(defun nxml-highlighted-qname (qname)
  (let ((colon (string-match ":" qname)))
    (if colon
	(concat (propertize (substring qname 0 colon)
			    'face
640
			    'nxml-element-prefix)
Mark A. Hershberger's avatar
Mark A. Hershberger committed
641 642 643
		nxml-highlighted-colon
		(propertize (substring qname (1+ colon))
			    'face
644
			    'nxml-element-local-name))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
645 646
      (propertize qname
		  'face
647
		  'nxml-element-local-name))))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
648 649 650 651 652 653 654 655 656 657 658 659 660

(defun nxml-outline-display-single-line-end-tag (last-pos)
  (nxml-outline-set-overlay 'nxml-outline-display-hide
			    last-pos
			    xmltok-start
			    nil
			    t)
  (overlay-put (nxml-outline-set-overlay 'nxml-outline-display-show
					 xmltok-start
					 (point)
					 t)
	       'display
	       nxml-highlighted-empty-end-tag))
661

Mark A. Hershberger's avatar
Mark A. Hershberger committed
662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724
(defun nxml-outline-display-multi-line-end-tag (last-pos start-tag-indent)
  (let ((indentp (save-excursion
		   (goto-char last-pos)
		   (skip-chars-forward " \t")
		   (and (eq (char-after) ?\n)
			(progn
			  (goto-char (1+ (point)))
			  (nxml-outline-set-overlay nil last-pos (point))
			  (setq last-pos (point))
			  (goto-char xmltok-start)
			  (beginning-of-line)
			  t))))
	end-tag-overlay)
    (nxml-outline-set-overlay 'nxml-outline-display-hide
			      last-pos
			      xmltok-start
			      nil
			      t)
    (setq end-tag-overlay
	  (nxml-outline-set-overlay 'nxml-outline-display-showing-tag
				    xmltok-start
				    (point)
				    t))
    (overlay-put end-tag-overlay
		 'display
		 (concat (if indentp
			     (make-string start-tag-indent ?\ )
			   "")
			 nxml-highlighted-less-than
			 nxml-highlighted-slash
			 nxml-highlighted-active-minus
			 (nxml-highlighted-qname (xmltok-end-tag-qname))
			 nxml-highlighted-greater-than))))

(defvar nxml-outline-show-map
  (let ((map (make-sparse-keymap)))
    (define-key map "\C-m" 'nxml-show-direct-text-content)
    (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content)
    map))

(defvar nxml-outline-show-help "mouse-2: show")

(put 'nxml-outline-display-show 'nxml-outline-display t)
(put 'nxml-outline-display-show 'evaporate t)
(put 'nxml-outline-display-show 'keymap nxml-outline-show-map)
(put 'nxml-outline-display-show 'help-echo nxml-outline-show-help)

(put 'nxml-outline-display-hide 'nxml-outline-display t)
(put 'nxml-outline-display-hide 'evaporate t)
(put 'nxml-outline-display-hide 'invisible t)
(put 'nxml-outline-display-hide 'keymap nxml-outline-show-map)
(put 'nxml-outline-display-hide 'help-echo nxml-outline-show-help)

(put 'nxml-outline-display-ellipsis 'nxml-outline-display t)
(put 'nxml-outline-display-ellipsis 'evaporate t)
(put 'nxml-outline-display-ellipsis 'keymap nxml-outline-show-map)
(put 'nxml-outline-display-ellipsis 'help-echo nxml-outline-show-help)
(put 'nxml-outline-display-ellipsis 'before-string nxml-highlighted-ellipsis)

(put 'nxml-outline-display-heading 'keymap nxml-outline-show-map)
(put 'nxml-outline-display-heading 'help-echo nxml-outline-show-help)
(put 'nxml-outline-display-heading 'nxml-outline-display t)
(put 'nxml-outline-display-heading 'evaporate t)
725
(put 'nxml-outline-display-heading 'face 'nxml-heading)
Mark A. Hershberger's avatar
Mark A. Hershberger committed
726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764

(defvar nxml-outline-hiding-tag-map
  (let ((map (make-sparse-keymap)))
    (define-key map [mouse-1] 'nxml-mouse-show-direct-subheadings)
    (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content)
    (define-key map "\C-m" 'nxml-show-direct-text-content)
    map))

(defvar nxml-outline-hiding-tag-help
  "mouse-1: show subheadings, mouse-2: show text content")

(put 'nxml-outline-display-hiding-tag 'nxml-outline-display t)
(put 'nxml-outline-display-hiding-tag 'evaporate t)
(put 'nxml-outline-display-hiding-tag 'keymap nxml-outline-hiding-tag-map)
(put 'nxml-outline-display-hiding-tag 'help-echo nxml-outline-hiding-tag-help)

(defvar nxml-outline-showing-tag-map
  (let ((map (make-sparse-keymap)))
    (define-key map [mouse-1] 'nxml-mouse-hide-subheadings)
    (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content)
    (define-key map "\C-m" 'nxml-show-direct-text-content)
    map))

(defvar nxml-outline-showing-tag-help
  "mouse-1: hide subheadings, mouse-2: show text content")

(put 'nxml-outline-display-showing-tag 'nxml-outline-display t)
(put 'nxml-outline-display-showing-tag 'evaporate t)
(put 'nxml-outline-display-showing-tag 'keymap nxml-outline-showing-tag-map)
(put 'nxml-outline-display-showing-tag
     'help-echo
     nxml-outline-showing-tag-help)

(defun nxml-outline-set-overlay (category
				 start
				 end
				 &optional
				 front-advance
				 rear-advance)
765
  "Replace any `nxml-outline-display' overlays between START and END.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
766
Overlays are removed if they overlay the region between START and END,
767 768 769 770
and have a non-nil `nxml-outline-display' property (typically via their
category).  If CATEGORY is non-nil, they will be replaced with a new
overlay with that category from START to END.  If CATEGORY is nil,
no new overlay will be created."
Mark A. Hershberger's avatar
Mark A. Hershberger committed
771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794
  (when (< start end)
    (let ((overlays (overlays-in start end))
	  overlay)
      (while overlays
	(setq overlay (car overlays))
	(setq overlays (cdr overlays))
	(when (overlay-get overlay 'nxml-outline-display)
	  (delete-overlay overlay))))
    (and category
	 (let ((overlay (make-overlay start
				      end
				      nil
				      front-advance
				      rear-advance)))
	   (overlay-put overlay 'category category)
	   (setq line-move-ignore-invisible t)
	   overlay))))

(defun nxml-end-of-heading ()
  "Move from the start of the content of the heading to the end.
Do not move past the end of the line."
  (let ((pos (condition-case err
		 (and (nxml-scan-element-forward (point) t)
		      xmltok-start)
795
	       (nxml-scan-error nil))))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836
    (end-of-line)
    (skip-chars-backward " \t")
    (cond ((not pos)
	   (setq pos (nxml-token-before))
	   (when (eq xmltok-type 'end-tag)
	     (goto-char pos)))
	  ((< pos (point))
	   (goto-char pos)))
    (skip-chars-backward " \t")
    (point)))

;;; Navigating section structure

(defun nxml-token-starts-line-p ()
  (save-excursion
    (goto-char xmltok-start)
    (skip-chars-backward " \t")
    (bolp)))

(defvar nxml-cached-section-tag-regexp nil)
(defvar nxml-cached-section-element-name-regexp nil)

(defsubst nxml-make-section-tag-regexp ()
  (if (eq nxml-cached-section-element-name-regexp
	  nxml-section-element-name-regexp)
      nxml-cached-section-tag-regexp
    (nxml-make-section-tag-regexp-1)))

(defun nxml-make-section-tag-regexp-1 ()
  (setq nxml-cached-section-element-name-regexp nil)
  (setq nxml-cached-section-tag-regexp
	(concat "</?\\("
		"\\(" xmltok-ncname-regexp ":\\)?"
		nxml-section-element-name-regexp
		"\\)[ \t\r\n>]"))
  (setq nxml-cached-section-element-name-regexp
	nxml-section-element-name-regexp)
  nxml-cached-section-tag-regexp)

(defun nxml-section-tag-forward ()
  "Move forward past the first tag that is a section start- or end-tag.
837
Return `xmltok-type' for tag.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865
If no tag found, return nil and move to the end of the buffer."
  (let ((case-fold-search nil)
	(tag-regexp (nxml-make-section-tag-regexp))
	match-end)
    (when (< (point) nxml-prolog-end)
      (goto-char nxml-prolog-end))
    (while (cond ((not (re-search-forward tag-regexp nil 'move))
		  (setq xmltok-type nil)
		  nil)
		 ((progn
		    (goto-char (match-beginning 0))
		    (setq match-end (match-end 0))
		    (nxml-ensure-scan-up-to-date)
		    (let ((end (nxml-inside-end (point))))
		      (when end
			(goto-char end)
			t))))
		 ((progn
		    (xmltok-forward)
		    (and (memq xmltok-type '(start-tag
					     partial-start-tag
					     end-tag
					     partial-end-tag))
			 ;; just in case wildcard matched non-name chars
			 (= xmltok-name-end (1- match-end))))
		  nil)
		 (t))))
    xmltok-type)
866

Mark A. Hershberger's avatar
Mark A. Hershberger committed
867 868
(defun nxml-section-tag-backward ()
  "Move backward to the end of a tag that is a section start- or end-tag.
869
The position of the end of the tag must be <= point.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921
Point is at the end of the tag.  `xmltok-start' is the start."
  (let ((case-fold-search nil)
	(start (point))
	(tag-regexp (nxml-make-section-tag-regexp))
	match-end)
    (if (< (point) nxml-prolog-end)
	(progn
	  (goto-char (point-min))
	  nil)
      (while (cond ((not (re-search-backward tag-regexp
					     nxml-prolog-end
					     'move))
		    (setq xmltok-type nil)
		    (goto-char (point-min))
		    nil)
		   ((progn
		      (goto-char (match-beginning 0))
		      (setq match-end (match-end 0))
		      (nxml-ensure-scan-up-to-date)
		      (let ((pos (nxml-inside-start (point))))
			(when pos
			  (goto-char (1- pos))
			  t))))
		   ((progn
		      (xmltok-forward)
		      (and (<= (point) start)
			   (memq xmltok-type '(start-tag
					       partial-start-tag
					       end-tag
					       partial-end-tag))
			   ;; just in case wildcard matched non-name chars
			   (= xmltok-name-end (1- match-end))))
		    nil)
		   (t (goto-char xmltok-start)
		      t)))
      xmltok-type)))

(defun nxml-section-start-position ()
  "Return the position of the start of the section containing point.
Signal an error on failure."
  (condition-case err
      (save-excursion (if (nxml-back-to-section-start)
			  (point)
			(error "Not in section")))
    (nxml-outline-error
     (nxml-report-outline-error "Couldn't determine containing section: %s"
				err))))

(defun nxml-back-to-section-start (&optional invisible-ok)
  "Try to move back to the start of the section containing point.
The start of the section must be <= point.
Only visible sections are included unless INVISIBLE-OK is non-nil.
922
If found, return t.  Otherwise move to `point-min' and return nil.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969
If unbalanced section tags are found, signal an `nxml-outline-error'."
  (when (or (nxml-after-section-start-tag)
	    (nxml-section-tag-backward))
    (let (open-tags found)
      (while (let (section-start-pos)
	       (setq section-start-pos xmltok-start)
	       (if (nxml-token-end-tag-p)
		   (setq open-tags (cons (xmltok-end-tag-qname)
					 open-tags))
		 (if (not open-tags)
		     (when (and (nxml-token-starts-line-p)
				(or invisible-ok
				    (not (get-char-property section-start-pos
							    'invisible)))
				(nxml-heading-start-position))
		       (setq found t))
		   (let ((qname (xmltok-start-tag-qname)))
		     (unless (string= (car open-tags) qname)
		       (nxml-outline-error "mismatched end-tag"))
		     (setq open-tags (cdr open-tags)))))
	       (goto-char section-start-pos)
	       (and (not found)
		    (nxml-section-tag-backward))))
      found)))

(defun nxml-after-section-start-tag ()
  "If the character after point is in a section start-tag, move after it.
Return the token type.  Otherwise return nil.
Set up variables like `xmltok-forward'."
  (let ((pos (nxml-token-after))
	(case-fold-search nil))
   (when (and (memq xmltok-type '(start-tag partial-start-tag))
	      (save-excursion
		(goto-char xmltok-start)
		(looking-at (nxml-make-section-tag-regexp))))
     (goto-char pos)
     xmltok-type)))

(defun nxml-heading-start-position ()
  "Return the position of the start of the content of a heading element.
Adjust the position to be after initial leading whitespace.
Return nil if no heading element is found.  Requires point to be
immediately after the section's start-tag."
  (let ((depth 0)
	(heading-regexp (concat "\\`\\("
				nxml-heading-element-name-regexp
				"\\)\\'"))
970

Mark A. Hershberger's avatar
Mark A. Hershberger committed
971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010
	(section-regexp (concat "\\`\\("
				nxml-section-element-name-regexp
				"\\)\\'"))
	(start (point))
	found)
    (save-excursion
      (while (and (xmltok-forward)
		  (cond ((memq xmltok-type '(end-tag partial-end-tag))
			 (and (not (string-match section-regexp
						 (xmltok-end-tag-local-name)))
			      (> depth 0)
			      (setq depth (1- depth))))
			;; XXX Not sure whether this is a good idea
			;;((eq xmltok-type 'empty-element)
			;; nil)
			((not (memq xmltok-type
				    '(start-tag partial-start-tag)))
			 t)
			((string-match section-regexp
				       (xmltok-start-tag-local-name))
			 nil)
			((string-match heading-regexp
				       (xmltok-start-tag-local-name))
			 (skip-chars-forward " \t\r\n")
			 (setq found (point))
			 nil)
			(t
			 (setq depth (1+ depth))
			 t))
		  (<= (- (point) start) nxml-heading-scan-distance))))
    found))

;;; Error handling

(defun nxml-report-outline-error (msg err)
  (error msg (apply 'format (cdr err))))

(defun nxml-outline-error (&rest args)
  (signal 'nxml-outline-error args))

1011 1012
(define-error 'nxml-outline-error
  "Cannot create outline of buffer that is not well-formed" 'nxml-error)
Mark A. Hershberger's avatar
Mark A. Hershberger committed
1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032

;;; Debugging

(defun nxml-debug-overlays ()
  (interactive)
  (let ((overlays (nreverse (overlays-in (point-min) (point-max))))
	overlay)
    (while overlays
      (setq overlay (car overlays))
      (setq overlays (cdr overlays))
      (when (overlay-get overlay 'nxml-outline-display)
	(message "overlay %s: %s...%s (%s)"
		 (overlay-get overlay 'category)
		 (overlay-start overlay)
		 (overlay-end overlay)
		 (overlay-get overlay 'display))))))

(provide 'nxml-outln)

;;; nxml-outln.el ends here