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

Glenn Morris's avatar
Glenn Morris committed
3
;; Copyright (C) 2004, 2007, 2008 Free Software Foundation, Inc.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
4 5 6 7

;; Author: James Clark
;; Keywords: XML

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

Glenn Morris's avatar
Glenn Morris committed
10 11 12 13
;; GNU Emacs 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.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
14

Glenn Morris's avatar
Glenn Morris committed
15 16 17 18 19 20 21 22 23
;; 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
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
Mark A. Hershberger's avatar
Mark A. Hershberger committed
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 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113

;;; 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.
;; The with-childen flavor is used when there are child sections.
;; 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"
  "*Regular expression matching the name of elements used as sections.
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"
  "*Regular expression matching the name of elements used as headings.
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
  "*Indentation in an outline for child element relative to parent element."
  :group 'nxml
  :type 'integer)

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

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

124 125
(defface nxml-outline-active-indicator
  '((t (:box t :inherit nxml-outline-indicator)))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
126
  "Face used for clickable `+' or `-' before element names in outlines."
127
  :group 'nxml-faces)
Mark A. Hershberger's avatar
Mark A. Hershberger committed
128

129
(defface nxml-outline-ellipsis
Mark A. Hershberger's avatar
Mark A. Hershberger committed
130 131
  '((t (:bold t :inherit default)))
  "Face used for `...' in outlines."
132
  :group 'nxml-faces)
Mark A. Hershberger's avatar
Mark A. Hershberger committed
133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 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 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 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 410 411 412 413 414

(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)
  (nxml-with-unmodifying-text-property-changes
    (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.
The visibility of headings at any level will not be changed. 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-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
will not be changed. 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-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
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)
  (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
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)
  (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]
would show only the heading of the subsections. 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 '((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
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 . 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
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 . 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
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)
  (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)))))
  
(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)
  (nxml-with-unmodifying-text-property-changes
    (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
415 416 417 418 419 420 421 422
(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)))

Mark A. Hershberger's avatar
Mark A. Hershberger committed
423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 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 512 513 514 515 516
(defun nxml-refresh-outline () 
  "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.
Leave point after the closing end-tag Return t if we had a
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
517
  (propertize "<" 'face 'nxml-tag-delimiter))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
518 519

(defconst nxml-highlighted-greater-than
520
  (propertize ">" 'face 'nxml-tag-delimiter))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
521 522

(defconst nxml-highlighted-colon
523
  (propertize ":" 'face 'nxml-element-colon))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
524 525

(defconst nxml-highlighted-slash
526
  (propertize "/" 'face 'nxml-tag-slash))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
527 528

(defconst nxml-highlighted-ellipsis
529
  (propertize "..." 'face 'nxml-outline-ellipsis))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
530 531 532 533 534 535 536 537

(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
538
  (propertize "-" 'face 'nxml-outline-indicator))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
539 540

(defconst nxml-highlighted-active-minus
541
  (propertize "-" 'face 'nxml-outline-active-indicator))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
542 543

(defconst nxml-highlighted-active-plus
544
  (propertize "+" 'face 'nxml-outline-active-indicator))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
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 640 641 642 643 644

(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
645
			    'nxml-element-prefix)
Mark A. Hershberger's avatar
Mark A. Hershberger committed
646 647 648
		nxml-highlighted-colon
		(propertize (substring qname (1+ colon))
			    'face
649
			    'nxml-element-local-name))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
650 651
      (propertize qname
		  'face
652
		  'nxml-element-local-name))))
Mark A. Hershberger's avatar
Mark A. Hershberger committed
653 654 655 656 657 658 659 660 661 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 725 726 727 728 729

(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))
    
(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)
730
(put 'nxml-outline-display-heading 'face 'nxml-heading)
Mark A. Hershberger's avatar
Mark A. Hershberger committed
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 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 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 837 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 866 867 868 869 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 922 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 970 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 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041

(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)
  "Replace any nxml-outline-display overlays between START and END.
Overlays are removed if they overlay the region between START and END,
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."
  (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)
	       nil)))
    (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.
Return xmltok-type for tag.
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)
	 
(defun nxml-section-tag-backward ()
  "Move backward to the end of a tag that is a section start- or end-tag.
The position of the end of the tag must be <= point
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.
If found, return t.  Otherwise move to point-min and return nil.
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
				"\\)\\'"))
	
	(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))

(put 'nxml-outline-error
     'error-conditions
     '(error nxml-error nxml-outline-error))

(put 'nxml-outline-error
     'error-message
     "Cannot create outline of buffer that is not well-formed")

;;; 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)

Miles Bader's avatar
Miles Bader committed
1042
;; arch-tag: 1f1b7454-e573-4cd7-a505-d9dc64eef828
Mark A. Hershberger's avatar
Mark A. Hershberger committed
1043
;;; nxml-outln.el ends here