lisp/nxml/nxml-outln.el

   1 ;;; nxml-outln.el --- outline support for nXML mode
   2
   3 ;; Copyright (C) 2004 Free Software Foundation, Inc.
   4
   5 ;; Author: James Clark
   6 ;; Keywords: XML
   7
   8 ;; This program is free software; you can redistribute it and/or
   9 ;; modify it under the terms of the GNU General Public License as
  10 ;; published by the Free Software Foundation; either version 2 of
  11 ;; the License, or (at your option) any later version.
  12
  13 ;; This program is distributed in the hope that it will be
  14 ;; useful, but WITHOUT ANY WARRANTY; without even the implied
  15 ;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  16 ;; PURPOSE.  See the GNU General Public License for more details.
  17
  18 ;; You should have received a copy of the GNU General Public
  19 ;; License along with this program; if not, write to the Free
  20 ;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
  21 ;; MA 02111-1307 USA
  22
  23 ;;; Commentary:
  24
  25 ;; A section can be in one of three states
  26 ;; 1. display normally; this displays each child section
  27 ;; according to its state; anything not part of child sections is also
  28 ;; displayed normally
  29 ;; 2. display just the title specially; child sections are not displayed
  30 ;; regardless of their state; anything not part of child sections is
  31 ;; not displayed
  32 ;; 3. display the title specially and display child sections
  33 ;; according to their state; anything not part of the child section is
  34 ;; not displayed
  35 ;; The state of a section is determined by the value of the
  36 ;; nxml-outline-state text property of the < character that starts
  37 ;; the section.
  38 ;; For state 1 the value is nil or absent.
  39 ;; For state 2 it is the symbol hide-children.
  40 ;; For state 3 it is t.
  41 ;; The special display is achieved by using overlays.  The overlays
  42 ;; are computed from the nxml-outline-state property by
  43 ;; `nxml-refresh-outline'. There overlays all have a category property
  44 ;; with an nxml-outline-display property with value t.
  45 ;;
  46 ;; For a section to be recognized as such, the following conditions must
  47 ;; be satisfied:
  48 ;; - its start-tag must occur at the start of a line (possibly indented)
  49 ;; - its local name must match `nxml-section-element-name-regexp'
  50 ;; - it must have a heading element; a heading element is an
  51 ;; element whose name matches `nxml-heading-element-name-regexp',
  52 ;; and that occurs as, or as a descendant of, the first child element
  53 ;; of the section
  54 ;;
  55 ;; XXX What happens if an nxml-outline-state property is attached to a
  56 ;; character that doesn't start a section element?
  57 ;;
  58 ;; An outlined section (an section with a non-nil nxml-outline-state
  59 ;; property) can be displayed in either single-line or multi-line
  60 ;; form.  Single-line form is used when the outline state is hide-children
  61 ;; or there are no child sections; multi-line form is used otherwise.
  62 ;; There are two flavors of single-line form: with children and without.
  63 ;; The with-childen flavor is used when there are child sections.
  64 ;; Single line with children looks like
  65 ;;    <+section>A section title...</>
  66 ;; Single line without children looks like
  67 ;;    <-section>A section title...</>
  68 ;; Multi line looks likes
  69 ;;    <-section>A section title...
  70 ;;    [child sections displayed here]
  71 ;;    </-section>
  72 ;; The indent of an outlined section is computed relative to the
  73 ;; outermost containing outlined element.  The indent of the
  74 ;; outermost containing element comes from the non-outlined
  75 ;; indent of the section start-tag.
  76
  77 ;;; Code:
  78
  79 (require 'xmltok)
  80 (require 'nxml-util)
  81 (require 'nxml-rap)
  82
  83 (defcustom nxml-section-element-name-regexp
  84   "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.
  86 An XML element is treated as a section if:
  87
  88 - its local name (that is, the name without the prefix) matches
  89 this regexp;
  90
  91 - either its first child element or a descendant of that first child
  92 element has a local name matching the variable
  93 `nxml-heading-element-name-regexp'; and
  94
  95 - its start-tag occurs at the beginning of a line (possibly indented)."
  96   :group 'nxml
  97   :type 'regexp)
  98
  99 (defcustom nxml-heading-element-name-regexp "title\\|head"
 100   "*Regular expression matching the name of elements used as headings.
 101 An XML element is only recognized as a heading if it occurs as or
 102 within the first child of an element that is recognized as a section.
 103 See the variable `nxml-section-element-name-regexp' for more details."
 104   :group 'nxml
 105   :type 'regexp)
 106
 107 (defcustom nxml-outline-child-indent 2
 108   "*Indentation in an outline for child element relative to parent element."
 109   :group 'nxml
 110   :type 'integer)
 111
 112 (defface nxml-heading-face
 113   '((t (:weight bold)))
 114   "Face used for the contents of abbreviated heading elements."
 115   :group 'nxml-highlighting-faces)
 116
 117 (defface nxml-outline-indicator-face
 118   '((t (:inherit default)))
 119   "Face used for `+' or `-' before element names in outlines."
 120   :group 'nxml-highlighting-faces)
 121
 122 (defface nxml-outline-active-indicator-face
 123   '((t (:box t :inherit nxml-outline-indicator-face)))
 124   "Face used for clickable `+' or `-' before element names in outlines."
 125   :group 'nxml-highlighting-faces)
 126
 127 (defface nxml-outline-ellipsis-face
 128   '((t (:bold t :inherit default)))
 129   "Face used for `...' in outlines."
 130   :group 'nxml-highlighting-faces)
 131
 132 (defvar nxml-heading-scan-distance 1000
 133   "Maximum distance from section to scan for heading.")
 134
 135 (defvar nxml-outline-prefix-map
 136   (let ((map (make-sparse-keymap)))
 137     (define-key map "\C-a" 'nxml-show-all)
 138     (define-key map "\C-t" 'nxml-hide-all-text-content)
 139     (define-key map "\C-r" 'nxml-refresh-outline)
 140     (define-key map "\C-c" 'nxml-hide-direct-text-content)
 141     (define-key map "\C-e" 'nxml-show-direct-text-content)
 142     (define-key map "\C-d" 'nxml-hide-subheadings)
 143     (define-key map "\C-s" 'nxml-show)
 144     (define-key map "\C-k" 'nxml-show-subheadings)
 145     (define-key map "\C-l" 'nxml-hide-text-content)
 146     (define-key map "\C-i" 'nxml-show-direct-subheadings)
 147     (define-key map "\C-o" 'nxml-hide-other)
 148     map))
 149
 150 ;;; Commands for changing visibility
 151
 152 (defun nxml-show-all ()
 153   "Show all elements in the buffer normally."
 154   (interactive)
 155   (nxml-with-unmodifying-text-property-changes
 156     (remove-text-properties (point-min)
 157                             (point-max)
 158                             '(nxml-outline-state nil)))
 159   (nxml-outline-set-overlay nil (point-min) (point-max)))
 160
 161 (defun nxml-hide-all-text-content ()
 162   "Hide all text content in the buffer.
 163 Anything that is in a section but is not a heading will be hidden.
 164 The visibility of headings at any level will not be changed. See the
 165 variable `nxml-section-element-name-regexp' for more details on how to
 166 customize which elements are recognized as sections and headings."
 167   (interactive)
 168   (nxml-transform-buffer-outline '((nil . t))))
 169
 170 (defun nxml-show-direct-text-content ()
 171   "Show the text content that is directly part of the section containing point.
 172 Each subsection will be shown according to its individual state, which
 173 will not be changed. The section containing point is the innermost
 174 section that contains the character following point. See the variable
 175 `nxml-section-element-name-regexp' for more details on how to
 176 customize which elements are recognized as sections and headings."
 177   (interactive)
 178   (nxml-outline-pre-adjust-point)
 179   (nxml-set-outline-state (nxml-section-start-position) nil)
 180   (nxml-refresh-outline)
 181   (nxml-outline-adjust-point))
 182
 183 (defun nxml-show-direct-subheadings ()
 184   "Show the immediate subheadings of the section containing point.
 185 The section containing point is the innermost section that contains
 186 the character following point. See the variable
 187 `nxml-section-element-name-regexp' for more details on how to
 188 customize which elements are recognized as sections and headings."
 189   (interactive)
 190   (let ((pos (nxml-section-start-position)))
 191     (when (eq (nxml-get-outline-state pos) 'hide-children)
 192       (nxml-set-outline-state pos t)))
 193   (nxml-refresh-outline)
 194   (nxml-outline-adjust-point))
 195
 196 (defun nxml-hide-direct-text-content ()
 197   "Hide the text content that is directly part of the section containing point.
 198 The heading of the section will remain visible.  The state of
 199 subsections will not be changed.  The section containing point is the
 200 innermost section that contains the character following point. See the
 201 variable `nxml-section-element-name-regexp' for more details on how to
 202 customize which elements are recognized as sections and headings."
 203   (interactive)
 204   (let ((pos (nxml-section-start-position)))
 205     (when (null (nxml-get-outline-state pos))
 206       (nxml-set-outline-state pos t)))
 207   (nxml-refresh-outline)
 208   (nxml-outline-adjust-point))
 209
 210 (defun nxml-hide-subheadings ()
 211   "Hide the subheadings that are part of the section containing point.
 212 The text content will also be hidden, leaving only the heading of the
 213 section itself visible.  The state of the subsections will also be
 214 changed to hide their headings, so that \\[nxml-show-direct-text-content]
 215 would show only the heading of the subsections. The section containing
 216 point is the innermost section that contains the character following
 217 point.  See the variable `nxml-section-element-name-regexp' for more
 218 details on how to customize which elements are recognized as sections
 219 and headings."
 220   (interactive)
 221   (nxml-transform-subtree-outline '((nil . hide-children)
 222                                     (t . hide-children))))
 223
 224 (defun nxml-show ()
 225   "Show the section containing point normally, without hiding anything.
 226 This includes everything in the section at any level.  The section
 227 containing point is the innermost section that contains the character
 228 following point.  See the variable `nxml-section-element-name-regexp'
 229 for more details on how to customize which elements are recognized as
 230 sections and headings."
 231   (interactive)
 232   (nxml-transform-subtree-outline '((hide-children . nil)
 233                                     (t . nil))))
 234
 235 (defun nxml-hide-text-content ()
 236   "Hide text content at all levels in the section containing point.
 237 The section containing point is the innermost section that contains
 238 the character following point. See the variable
 239 `nxml-section-element-name-regexp' for more details on how to
 240 customize which elements are recognized as sections and headings."
 241   (interactive)
 242   (nxml-transform-subtree-outline '((nil . t))))
 243
 244 (defun nxml-show-subheadings ()
 245   "Show the subheadings at all levels of the section containing point.
 246 The visibility of the text content at all levels in the section is not
 247 changed.  The section containing point is the innermost section that
 248 contains the character following point. See the variable
 249 `nxml-section-element-name-regexp' for more details on how to
 250 customize which elements are recognized as sections and headings."
 251   (interactive)
 252   (nxml-transform-subtree-outline '((hide-children . t))))
 253
 254 (defun nxml-hide-other ()
 255   "Hide text content other than that directly in the section containing point.
 256 Hide headings other than those of ancestors of that section and their
 257 immediate subheadings.  The section containing point is the innermost
 258 section that contains the character following point. See the variable
 259 `nxml-section-element-name-regexp' for more details on how to
 260 customize which elements are recognized as sections and headings."
 261   (interactive)
 262   (let ((nxml-outline-state-transform-exceptions nil))
 263     (save-excursion
 264       (while (and (condition-case err
 265                       (nxml-back-to-section-start)
 266                     (nxml-outline-error (nxml-report-outline-error
 267                                          "Couldn't find containing section: %s"
 268                                          err)))
 269                   (progn
 270                     (when (and nxml-outline-state-transform-exceptions
 271                                (null (nxml-get-outline-state (point))))
 272                       (nxml-set-outline-state (point) t))
 273                     (setq nxml-outline-state-transform-exceptions
 274                           (cons (point)
 275                                 nxml-outline-state-transform-exceptions))
 276                     (< nxml-prolog-end (point))))
 277         (goto-char (1- (point)))))
 278     (nxml-transform-buffer-outline '((nil . hide-children)
 279                                      (t . hide-children)))))
 280
 281 ;; These variables are dynamically bound.  They are use to pass information to
 282 ;; nxml-section-tag-transform-outline-state.
 283
 284 (defvar nxml-outline-state-transform-exceptions nil)
 285 (defvar nxml-target-section-pos nil)
 286 (defvar nxml-depth-in-target-section nil)
 287 (defvar nxml-outline-state-transform-alist nil)
 288
 289 (defun nxml-transform-buffer-outline (alist)
 290   (let ((nxml-target-section-pos nil)
 291         (nxml-depth-in-target-section 0)
 292         (nxml-outline-state-transform-alist alist)
 293         (nxml-outline-display-section-tag-function
 294          'nxml-section-tag-transform-outline-state))
 295     (nxml-refresh-outline))
 296   (nxml-outline-adjust-point))
 297
 298 (defun nxml-transform-subtree-outline (alist)
 299   (let ((nxml-target-section-pos (nxml-section-start-position))
 300         (nxml-depth-in-target-section nil)
 301         (nxml-outline-state-transform-alist alist)
 302         (nxml-outline-display-section-tag-function
 303          'nxml-section-tag-transform-outline-state))
 304     (nxml-refresh-outline))
 305   (nxml-outline-adjust-point))
 306
 307 (defun nxml-outline-pre-adjust-point ()
 308   (cond ((and (< (point-min) (point))
 309               (get-char-property (1- (point)) 'invisible)
 310               (not (get-char-property (point) 'invisible))
 311               (let ((str (or (get-char-property (point) 'before-string)
 312                              (get-char-property (point) 'display))))
 313                 (and (stringp str)
 314                      (>= (length str) 3)
 315                      (string= (substring str 0 3) "..."))))
 316          ;; The ellipsis is a display property on a visible character
 317          ;; following an invisible region. The position of the event
 318          ;; will be the position before that character. We want to
 319          ;; move point to the other side of the invisible region, i.e.
 320          ;; following the last visible character before that invisible
 321          ;; region.
 322          (goto-char (previous-single-char-property-change (1- (point))
 323                                                           'invisible)))
 324         ((and (< (point) (point-max))
 325               (get-char-property (point) 'display)
 326               (get-char-property (1+ (point)) 'invisible))
 327          (goto-char (next-single-char-property-change (1+ (point))
 328                                                       'invisible)))
 329         ((and (< (point) (point-max))
 330               (get-char-property (point) 'invisible))
 331          (goto-char (next-single-char-property-change (point)
 332                                                       'invisible)))))
 333
 334 (defun nxml-outline-adjust-point ()
 335   "Adjust point after showing or hiding elements."
 336   (when (and (get-char-property (point) 'invisible)
 337              (< (point-min) (point))
 338              (get-char-property (1- (point)) 'invisible))
 339     (goto-char (previous-single-char-property-change (point)
 340                                                      'invisible
 341                                                      nil
 342                                                      nxml-prolog-end))))
 343
 344 (defun nxml-transform-outline-state (section-start-pos)
 345   (let* ((old-state
 346           (nxml-get-outline-state section-start-pos))
 347          (change (assq old-state
 348                        nxml-outline-state-transform-alist)))
 349     (when change
 350       (nxml-set-outline-state section-start-pos
 351                               (cdr change)))))
 352
 353 (defun nxml-section-tag-transform-outline-state (startp
 354                                                  section-start-pos
 355                                                  &optional
 356                                                  heading-start-pos)
 357   (if (not startp)
 358       (setq nxml-depth-in-target-section
 359             (and nxml-depth-in-target-section
 360                  (> nxml-depth-in-target-section 0)
 361                  (1- nxml-depth-in-target-section)))
 362     (cond (nxml-depth-in-target-section
 363            (setq nxml-depth-in-target-section
 364                  (1+ nxml-depth-in-target-section)))
 365           ((= section-start-pos nxml-target-section-pos)
 366            (setq nxml-depth-in-target-section 0)))
 367     (when (and nxml-depth-in-target-section
 368                (not (member section-start-pos
 369                             nxml-outline-state-transform-exceptions)))
 370       (nxml-transform-outline-state section-start-pos))))
 371
 372 (defun nxml-get-outline-state (pos)
 373   (get-text-property pos 'nxml-outline-state))
 374
 375 (defun nxml-set-outline-state (pos state)
 376   (nxml-with-unmodifying-text-property-changes
 377     (if state
 378         (put-text-property pos (1+ pos) 'nxml-outline-state state)
 379       (remove-text-properties pos (1+ pos) '(nxml-outline-state nil)))))
 380
 381 ;;; Mouse interface
 382
 383 (defun nxml-mouse-show-direct-text-content (event)
 384   "Do the same as \\[nxml-show-direct-text-content] from a mouse click."
 385   (interactive "e")
 386   (and (nxml-mouse-set-point event)
 387        (nxml-show-direct-text-content)))
 388
 389 (defun nxml-mouse-hide-direct-text-content (event)
 390   "Do the same as \\[nxml-hide-direct-text-content] from a mouse click."
 391   (interactive "e")
 392   (and (nxml-mouse-set-point event)
 393        (nxml-hide-direct-text-content)))
 394
 395 (defun nxml-mouse-hide-subheadings (event)
 396   "Do the same as \\[nxml-hide-subheadings] from a mouse click."
 397   (interactive "e")
 398   (and (nxml-mouse-set-point event)
 399        (nxml-hide-subheadings)))
 400
 401 (defun nxml-mouse-show-direct-subheadings (event)
 402   "Do the same as \\[nxml-show-direct-subheadings] from a mouse click."
 403   (interactive "e")
 404   (and (nxml-mouse-set-point event)
 405        (nxml-show-direct-subheadings)))
 406
 407 (defun nxml-mouse-set-point (event)
 408   (mouse-set-point event)
 409   (and nxml-prolog-end t))
 410
 411 ;; Display
 412
 413 (defun nxml-refresh-outline ()
 414   "Refresh the outline to correspond to the current XML element structure."
 415   (interactive)
 416   (save-excursion
 417     (goto-char (point-min))
 418     (kill-local-variable 'line-move-ignore-invisible)
 419     (make-local-variable 'line-move-ignore-invisible)
 420     (condition-case err
 421         (nxml-outline-display-rest nil nil nil)
 422       (nxml-outline-error
 423        (nxml-report-outline-error "Cannot display outline: %s" err)))))
 424
 425 (defvar nxml-outline-display-section-tag-function nil)
 426
 427 (defun nxml-outline-display-rest (outline-state start-tag-indent tag-qnames)
 428   "Display up to and including the end of the current element.
 429 OUTLINE-STATE can be nil, t, hide-children.  START-TAG-INDENT is the
 430 indent of the start-tag of the current element, or nil if no
 431 containing element has a non-nil OUTLINE-STATE.  TAG-QNAMES is a list
 432 of the qnames of the open elements.  Point is after the title content.
 433 Leave point after the closing end-tag Return t if we had a
 434 non-transparent child section."
 435   (let ((last-pos (point))
 436         (transparent-depth 0)
 437         ;; don't want ellipsis before root element
 438         (had-children (not tag-qnames)))
 439     (while
 440         (cond ((not (nxml-section-tag-forward))
 441                (if (null tag-qnames)
 442                    nil
 443                  (nxml-outline-error "missing end-tag %s"
 444                                      (car tag-qnames))))
 445               ;; section end-tag
 446               ((nxml-token-end-tag-p)
 447                (when nxml-outline-display-section-tag-function
 448                  (funcall nxml-outline-display-section-tag-function
 449                           nil
 450                           xmltok-start))
 451                (let ((qname (xmltok-end-tag-qname)))
 452                  (unless tag-qnames
 453                    (nxml-outline-error "extra end-tag %s" qname))
 454                  (unless (string= (car tag-qnames) qname)
 455                    (nxml-outline-error "mismatched end-tag; expected %s, got %s"
 456                                        (car tag-qnames)
 457                                        qname)))
 458                (cond ((> transparent-depth 0)
 459                       (setq transparent-depth (1- transparent-depth))
 460                       (setq tag-qnames (cdr tag-qnames))
 461                       t)
 462                      ((not outline-state)
 463                       (nxml-outline-set-overlay nil last-pos (point))
 464                       nil)
 465                      ((or (not had-children)
 466                           (eq outline-state 'hide-children))
 467                       (nxml-outline-display-single-line-end-tag last-pos)
 468                       nil)
 469                      (t
 470                       (nxml-outline-display-multi-line-end-tag last-pos
 471                                                                start-tag-indent)
 472                       nil)))
 473               ;; section start-tag
 474               (t
 475                (let* ((qname (xmltok-start-tag-qname))
 476                       (section-start-pos xmltok-start)
 477                       (heading-start-pos
 478                        (and (or nxml-outline-display-section-tag-function
 479                                 (not (eq outline-state 'had-children))
 480                                 (not had-children))
 481                             (nxml-token-starts-line-p)
 482                             (nxml-heading-start-position))))
 483                  (when nxml-outline-display-section-tag-function
 484                    (funcall nxml-outline-display-section-tag-function
 485                             t
 486                             section-start-pos
 487                             heading-start-pos))
 488                  (setq tag-qnames (cons qname tag-qnames))
 489                  (if (or (not heading-start-pos)
 490                          (and (eq outline-state 'hide-children)
 491                               (setq had-children t)))
 492                      (setq transparent-depth (1+ transparent-depth))
 493                    (nxml-display-section last-pos
 494                                          section-start-pos
 495                                          heading-start-pos
 496                                          start-tag-indent
 497                                          outline-state
 498                                          had-children
 499                                          tag-qnames)
 500                    (setq had-children t)
 501                    (setq tag-qnames (cdr tag-qnames))
 502                    (setq last-pos (point))))
 503                t)))
 504     had-children))
 505
 506 (defconst nxml-highlighted-less-than
 507   (propertize "<" 'face 'nxml-tag-delimiter-face))
 508
 509 (defconst nxml-highlighted-greater-than
 510   (propertize ">" 'face 'nxml-tag-delimiter-face))
 511
 512 (defconst nxml-highlighted-colon
 513   (propertize ":" 'face 'nxml-element-colon-face))
 514
 515 (defconst nxml-highlighted-slash
 516   (propertize "/" 'face 'nxml-tag-slash-face))
 517
 518 (defconst nxml-highlighted-ellipsis
 519   (propertize "..." 'face 'nxml-outline-ellipsis-face))
 520
 521 (defconst nxml-highlighted-empty-end-tag
 522   (concat nxml-highlighted-ellipsis
 523           nxml-highlighted-less-than
 524           nxml-highlighted-slash
 525           nxml-highlighted-greater-than))
 526
 527 (defconst nxml-highlighted-inactive-minus
 528   (propertize "-" 'face 'nxml-outline-indicator-face))
 529
 530 (defconst nxml-highlighted-active-minus
 531   (propertize "-" 'face 'nxml-outline-active-indicator-face))
 532
 533 (defconst nxml-highlighted-active-plus
 534   (propertize "+" 'face 'nxml-outline-active-indicator-face))
 535
 536 (defun nxml-display-section (last-pos
 537                              section-start-pos
 538                              heading-start-pos
 539                              parent-indent
 540                              parent-outline-state
 541                              had-children
 542                              tag-qnames)
 543   (let* ((section-start-pos-bol
 544           (save-excursion
 545             (goto-char section-start-pos)
 546             (skip-chars-backward " \t")
 547             (point)))
 548          (outline-state (nxml-get-outline-state section-start-pos))
 549          (newline-before-section-start-category
 550           (cond ((and (not had-children) parent-outline-state)
 551                  'nxml-outline-display-ellipsis)
 552                  (outline-state 'nxml-outline-display-show)
 553                  (t nil))))
 554     (nxml-outline-set-overlay (and parent-outline-state
 555                                    'nxml-outline-display-hide)
 556                               last-pos
 557                               (1- section-start-pos-bol)
 558                               nil
 559                               t)
 560     (if outline-state
 561       (let* ((indent (if parent-indent
 562                          (+ parent-indent nxml-outline-child-indent)
 563                        (save-excursion
 564                          (goto-char section-start-pos)
 565                          (current-column))))
 566              start-tag-overlay)
 567         (nxml-outline-set-overlay newline-before-section-start-category
 568                                   (1- section-start-pos-bol)
 569                                   section-start-pos-bol
 570                                   t)
 571         (nxml-outline-set-overlay 'nxml-outline-display-hide
 572                                   section-start-pos-bol
 573                                   section-start-pos)
 574         (setq start-tag-overlay
 575             (nxml-outline-set-overlay 'nxml-outline-display-show
 576                                       section-start-pos
 577                                       (1+ section-start-pos)
 578                                       t))
 579         ;; line motion commands don't work right if start-tag-overlay
 580         ;; covers multiple lines
 581         (nxml-outline-set-overlay 'nxml-outline-display-hide
 582                                   (1+ section-start-pos)
 583                                   heading-start-pos)
 584         (goto-char heading-start-pos)
 585         (nxml-end-of-heading)
 586         (nxml-outline-set-overlay 'nxml-outline-display-heading
 587                                   heading-start-pos
 588                                   (point))
 589         (let* ((had-children
 590                 (nxml-outline-display-rest outline-state
 591                                            indent
 592                                            tag-qnames)))
 593           (overlay-put start-tag-overlay
 594                        'display
 595                        (concat
 596                         ;; indent
 597                         (make-string indent ?\ )
 598                         ;; <
 599                         nxml-highlighted-less-than
 600                         ;; + or - indicator
 601                         (cond ((not had-children)
 602                                nxml-highlighted-inactive-minus)
 603                               ((eq outline-state 'hide-children)
 604                                (overlay-put start-tag-overlay
 605                                             'category
 606                                             'nxml-outline-display-hiding-tag)
 607                                nxml-highlighted-active-plus)
 608                               (t
 609                                (overlay-put start-tag-overlay
 610                                             'category
 611                                             'nxml-outline-display-showing-tag)
 612                                nxml-highlighted-active-minus))
 613                         ;; qname
 614                         (nxml-highlighted-qname (car tag-qnames))
 615                         ;; >
 616                         nxml-highlighted-greater-than))))
 617       ;; outline-state nil
 618       (goto-char heading-start-pos)
 619       (nxml-end-of-heading)
 620       (nxml-outline-set-overlay newline-before-section-start-category
 621                                 (1- section-start-pos-bol)
 622                                 (point)
 623                                 t)
 624       (nxml-outline-display-rest outline-state
 625                                  (and parent-indent
 626                                       (+ parent-indent
 627                                          nxml-outline-child-indent))
 628                                  tag-qnames))))
 629
 630 (defun nxml-highlighted-qname (qname)
 631   (let ((colon (string-match ":" qname)))
 632     (if colon
 633         (concat (propertize (substring qname 0 colon)
 634                             'face
 635                             'nxml-element-prefix-face)
 636                 nxml-highlighted-colon
 637                 (propertize (substring qname (1+ colon))
 638                             'face
 639                             'nxml-element-local-name-face))
 640       (propertize qname
 641                   'face
 642                   'nxml-element-local-name-face))))
 643
 644 (defun nxml-outline-display-single-line-end-tag (last-pos)
 645   (nxml-outline-set-overlay 'nxml-outline-display-hide
 646                             last-pos
 647                             xmltok-start
 648                             nil
 649                             t)
 650   (overlay-put (nxml-outline-set-overlay 'nxml-outline-display-show
 651                                          xmltok-start
 652                                          (point)
 653                                          t)
 654                'display
 655                nxml-highlighted-empty-end-tag))
 656
 657 (defun nxml-outline-display-multi-line-end-tag (last-pos start-tag-indent)
 658   (let ((indentp (save-excursion
 659                    (goto-char last-pos)
 660                    (skip-chars-forward " \t")
 661                    (and (eq (char-after) ?\n)
 662                         (progn
 663                           (goto-char (1+ (point)))
 664                           (nxml-outline-set-overlay nil last-pos (point))
 665                           (setq last-pos (point))
 666                           (goto-char xmltok-start)
 667                           (beginning-of-line)
 668                           t))))
 669         end-tag-overlay)
 670     (nxml-outline-set-overlay 'nxml-outline-display-hide
 671                               last-pos
 672                               xmltok-start
 673                               nil
 674                               t)
 675     (setq end-tag-overlay
 676           (nxml-outline-set-overlay 'nxml-outline-display-showing-tag
 677                                     xmltok-start
 678                                     (point)
 679                                     t))
 680     (overlay-put end-tag-overlay
 681                  'display
 682                  (concat (if indentp
 683                              (make-string start-tag-indent ?\ )
 684                            "")
 685                          nxml-highlighted-less-than
 686                          nxml-highlighted-slash
 687                          nxml-highlighted-active-minus
 688                          (nxml-highlighted-qname (xmltok-end-tag-qname))
 689                          nxml-highlighted-greater-than))))
 690
 691 (defvar nxml-outline-show-map
 692   (let ((map (make-sparse-keymap)))
 693     (define-key map "\C-m" 'nxml-show-direct-text-content)
 694     (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content)
 695     map))
 696
 697 (defvar nxml-outline-show-help "mouse-2: show")
 698
 699 (put 'nxml-outline-display-show 'nxml-outline-display t)
 700 (put 'nxml-outline-display-show 'evaporate t)
 701 (put 'nxml-outline-display-show 'keymap nxml-outline-show-map)
 702 (put 'nxml-outline-display-show 'help-echo nxml-outline-show-help)
 703
 704 (put 'nxml-outline-display-hide 'nxml-outline-display t)
 705 (put 'nxml-outline-display-hide 'evaporate t)
 706 (put 'nxml-outline-display-hide 'invisible t)
 707 (put 'nxml-outline-display-hide 'keymap nxml-outline-show-map)
 708 (put 'nxml-outline-display-hide 'help-echo nxml-outline-show-help)
 709
 710 (put 'nxml-outline-display-ellipsis 'nxml-outline-display t)
 711 (put 'nxml-outline-display-ellipsis 'evaporate t)
 712 (put 'nxml-outline-display-ellipsis 'keymap nxml-outline-show-map)
 713 (put 'nxml-outline-display-ellipsis 'help-echo nxml-outline-show-help)
 714 (put 'nxml-outline-display-ellipsis 'before-string nxml-highlighted-ellipsis)
 715
 716 (put 'nxml-outline-display-heading 'keymap nxml-outline-show-map)
 717 (put 'nxml-outline-display-heading 'help-echo nxml-outline-show-help)
 718 (put 'nxml-outline-display-heading 'nxml-outline-display t)
 719 (put 'nxml-outline-display-heading 'evaporate t)
 720 (put 'nxml-outline-display-heading 'face 'nxml-heading-face)
 721
 722 (defvar nxml-outline-hiding-tag-map
 723   (let ((map (make-sparse-keymap)))
 724     (define-key map [mouse-1] 'nxml-mouse-show-direct-subheadings)
 725     (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content)
 726     (define-key map "\C-m" 'nxml-show-direct-text-content)
 727     map))
 728
 729 (defvar nxml-outline-hiding-tag-help
 730   "mouse-1: show subheadings, mouse-2: show text content")
 731
 732 (put 'nxml-outline-display-hiding-tag 'nxml-outline-display t)
 733 (put 'nxml-outline-display-hiding-tag 'evaporate t)
 734 (put 'nxml-outline-display-hiding-tag 'keymap nxml-outline-hiding-tag-map)
 735 (put 'nxml-outline-display-hiding-tag 'help-echo nxml-outline-hiding-tag-help)
 736
 737 (defvar nxml-outline-showing-tag-map
 738   (let ((map (make-sparse-keymap)))
 739     (define-key map [mouse-1] 'nxml-mouse-hide-subheadings)
 740     (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content)
 741     (define-key map "\C-m" 'nxml-show-direct-text-content)
 742     map))
 743
 744 (defvar nxml-outline-showing-tag-help
 745   "mouse-1: hide subheadings, mouse-2: show text content")
 746
 747 (put 'nxml-outline-display-showing-tag 'nxml-outline-display t)
 748 (put 'nxml-outline-display-showing-tag 'evaporate t)
 749 (put 'nxml-outline-display-showing-tag 'keymap nxml-outline-showing-tag-map)
 750 (put 'nxml-outline-display-showing-tag
 751      'help-echo
 752      nxml-outline-showing-tag-help)
 753
 754 (defun nxml-outline-set-overlay (category
 755                                  start
 756                                  end
 757                                  &optional
 758                                  front-advance
 759                                  rear-advance)
 760   "Replace any nxml-outline-display overlays between START and END.
 761 Overlays are removed if they overlay the region between START and END,
 762 and have a non-nil nxml-outline-display property (typically via their
 763 category). If CATEGORY is non-nil, they will be replaced with a new overlay
 764 with that category from START to END. If CATEGORY is nil, no new
 765 overlay will be created."
 766   (when (< start end)
 767     (let ((overlays (overlays-in start end))
 768           overlay)
 769       (while overlays
 770         (setq overlay (car overlays))
 771         (setq overlays (cdr overlays))
 772         (when (overlay-get overlay 'nxml-outline-display)
 773           (delete-overlay overlay))))
 774     (and category
 775          (let ((overlay (make-overlay start
 776                                       end
 777                                       nil
 778                                       front-advance
 779                                       rear-advance)))
 780            (overlay-put overlay 'category category)
 781            (setq line-move-ignore-invisible t)
 782            overlay))))
 783
 784 (defun nxml-end-of-heading ()
 785   "Move from the start of the content of the heading to the end.
 786 Do not move past the end of the line."
 787   (let ((pos (condition-case err
 788                  (and (nxml-scan-element-forward (point) t)
 789                       xmltok-start)
 790                nil)))
 791     (end-of-line)
 792     (skip-chars-backward " \t")
 793     (cond ((not pos)
 794            (setq pos (nxml-token-before))
 795            (when (eq xmltok-type 'end-tag)
 796              (goto-char pos)))
 797           ((< pos (point))
 798            (goto-char pos)))
 799     (skip-chars-backward " \t")
 800     (point)))
 801
 802 ;;; Navigating section structure
 803
 804 (defsubst nxml-token-start-tag-p ()
 805   (or (eq xmltok-type 'start-tag)
 806       (eq xmltok-type 'partial-start-tag)))
 807
 808 (defsubst nxml-token-end-tag-p ()
 809   (or (eq xmltok-type 'end-tag)
 810       (eq xmltok-type 'partial-end-tag)))
 811
 812 (defun nxml-token-starts-line-p ()
 813   (save-excursion
 814     (goto-char xmltok-start)
 815     (skip-chars-backward " \t")
 816     (bolp)))
 817
 818 (defvar nxml-cached-section-tag-regexp nil)
 819 (defvar nxml-cached-section-element-name-regexp nil)
 820
 821 (defsubst nxml-make-section-tag-regexp ()
 822   (if (eq nxml-cached-section-element-name-regexp
 823           nxml-section-element-name-regexp)
 824       nxml-cached-section-tag-regexp
 825     (nxml-make-section-tag-regexp-1)))
 826
 827 (defun nxml-make-section-tag-regexp-1 ()
 828   (setq nxml-cached-section-element-name-regexp nil)
 829   (setq nxml-cached-section-tag-regexp
 830         (concat "</?\\("
 831                 "\\(" xmltok-ncname-regexp ":\\)?"
 832                 nxml-section-element-name-regexp
 833                 "\\)[ \t\r\n>]"))
 834   (setq nxml-cached-section-element-name-regexp
 835         nxml-section-element-name-regexp)
 836   nxml-cached-section-tag-regexp)
 837
 838 (defun nxml-section-tag-forward ()
 839   "Move forward past the first tag that is a section start- or end-tag.
 840 Return xmltok-type for tag.
 841 If no tag found, return nil and move to the end of the buffer."
 842   (let ((case-fold-search nil)
 843         (tag-regexp (nxml-make-section-tag-regexp))
 844         match-end)
 845     (when (< (point) nxml-prolog-end)
 846       (goto-char nxml-prolog-end))
 847     (while (cond ((not (re-search-forward tag-regexp nil 'move))
 848                   (setq xmltok-type nil)
 849                   nil)
 850                  ((progn
 851                     (goto-char (match-beginning 0))
 852                     (setq match-end (match-end 0))
 853                     (nxml-ensure-scan-up-to-date)
 854                     (let ((end (nxml-inside-end (point))))
 855                       (when end
 856                         (goto-char end)
 857                         t))))
 858                  ((progn
 859                     (xmltok-forward)
 860                     (and (memq xmltok-type '(start-tag
 861                                              partial-start-tag
 862                                              end-tag
 863                                              partial-end-tag))
 864                          ;; just in case wildcard matched non-name chars
 865                          (= xmltok-name-end (1- match-end))))
 866                   nil)
 867                  (t))))
 868     xmltok-type)
 869
 870 (defun nxml-section-tag-backward ()
 871   "Move backward to the end of a tag that is a section start- or end-tag.
 872 The position of the end of the tag must be <= point
 873 Point is at the end of the tag.  `xmltok-start' is the start."
 874   (let ((case-fold-search nil)
 875         (start (point))
 876         (tag-regexp (nxml-make-section-tag-regexp))
 877         match-end)
 878     (if (< (point) nxml-prolog-end)
 879         (progn
 880           (goto-char (point-min))
 881           nil)
 882       (while (cond ((not (re-search-backward tag-regexp
 883                                              nxml-prolog-end
 884                                              'move))
 885                     (setq xmltok-type nil)
 886                     (goto-char (point-min))
 887                     nil)
 888                    ((progn
 889                       (goto-char (match-beginning 0))
 890                       (setq match-end (match-end 0))
 891                       (nxml-ensure-scan-up-to-date)
 892                       (let ((pos (nxml-inside-start (point))))
 893                         (when pos
 894                           (goto-char (1- pos))
 895                           t))))
 896                    ((progn
 897                       (xmltok-forward)
 898                       (and (<= (point) start)
 899                            (memq xmltok-type '(start-tag
 900                                                partial-start-tag
 901                                                end-tag
 902                                                partial-end-tag))
 903                            ;; just in case wildcard matched non-name chars
 904                            (= xmltok-name-end (1- match-end))))
 905                     nil)
 906                    (t (goto-char xmltok-start)
 907                       t)))
 908       xmltok-type)))
 909
 910 (defun nxml-section-start-position ()
 911   "Return the position of the start of the section containing point.
 912 Signal an error on failure."
 913   (condition-case err
 914       (save-excursion (if (nxml-back-to-section-start)
 915                           (point)
 916                         (error "Not in section")))
 917     (nxml-outline-error
 918      (nxml-report-outline-error "Couldn't determine containing section: %s"
 919                                 err))))
 920
 921 (defun nxml-back-to-section-start (&optional invisible-ok)
 922   "Try to move back to the start of the section containing point.
 923 The start of the section must be <= point.
 924 Only visible sections are included unless INVISIBLE-OK is non-nil.
 925 If found, return t.  Otherwise move to point-min and return nil.
 926 If unbalanced section tags are found, signal an `nxml-outline-error'."
 927   (when (or (nxml-after-section-start-tag)
 928             (nxml-section-tag-backward))
 929     (let (open-tags found)
 930       (while (let (section-start-pos)
 931                (setq section-start-pos xmltok-start)
 932                (if (nxml-token-end-tag-p)
 933                    (setq open-tags (cons (xmltok-end-tag-qname)
 934                                          open-tags))
 935                  (if (not open-tags)
 936                      (when (and (nxml-token-starts-line-p)
 937                                 (or invisible-ok
 938                                     (not (get-char-property section-start-pos
 939                                                             'invisible)))
 940                                 (nxml-heading-start-position))
 941                        (setq found t))
 942                    (let ((qname (xmltok-start-tag-qname)))
 943                      (unless (string= (car open-tags) qname)
 944                        (nxml-outline-error "mismatched end-tag"))
 945                      (setq open-tags (cdr open-tags)))))
 946                (goto-char section-start-pos)
 947                (and (not found)
 948                     (nxml-section-tag-backward))))
 949       found)))
 950
 951 (defun nxml-after-section-start-tag ()
 952   "If the character after point is in a section start-tag, move after it.
 953 Return the token type.  Otherwise return nil.
 954 Set up variables like `xmltok-forward'."
 955   (let ((pos (nxml-token-after))
 956         (case-fold-search nil))
 957    (when (and (memq xmltok-type '(start-tag partial-start-tag))
 958               (save-excursion
 959                 (goto-char xmltok-start)
 960                 (looking-at (nxml-make-section-tag-regexp))))
 961      (goto-char pos)
 962      xmltok-type)))
 963
 964 (defun nxml-heading-start-position ()
 965   "Return the position of the start of the content of a heading element.
 966 Adjust the position to be after initial leading whitespace.
 967 Return nil if no heading element is found.  Requires point to be
 968 immediately after the section's start-tag."
 969   (let ((depth 0)
 970         (heading-regexp (concat "\\`\\("
 971                                 nxml-heading-element-name-regexp
 972                                 "\\)\\'"))
 973
 974         (section-regexp (concat "\\`\\("
 975                                 nxml-section-element-name-regexp
 976                                 "\\)\\'"))
 977         (start (point))
 978         found)
 979     (save-excursion
 980       (while (and (xmltok-forward)
 981                   (cond ((memq xmltok-type '(end-tag partial-end-tag))
 982                          (and (not (string-match section-regexp
 983                                                  (xmltok-end-tag-local-name)))
 984                               (> depth 0)
 985                               (setq depth (1- depth))))
 986                         ;; XXX Not sure whether this is a good idea
 987                         ;;((eq xmltok-type 'empty-element)
 988                         ;; nil)
 989                         ((not (memq xmltok-type
 990                                     '(start-tag partial-start-tag)))
 991                          t)
 992                         ((string-match section-regexp
 993                                        (xmltok-start-tag-local-name))
 994                          nil)
 995                         ((string-match heading-regexp
 996                                        (xmltok-start-tag-local-name))
 997                          (skip-chars-forward " \t\r\n")
 998                          (setq found (point))
 999                          nil)
1000                         (t
1001                          (setq depth (1+ depth))
1002                          t))
1003                   (<= (- (point) start) nxml-heading-scan-distance))))
1004     found))
1005
1006 ;;; Error handling
1007
1008 (defun nxml-report-outline-error (msg err)
1009   (error msg (apply 'format (cdr err))))
1010
1011 (defun nxml-outline-error (&rest args)
1012   (signal 'nxml-outline-error args))
1013
1014 (put 'nxml-outline-error
1015      'error-conditions
1016      '(error nxml-error nxml-outline-error))
1017
1018 (put 'nxml-outline-error
1019      'error-message
1020      "Cannot create outline of buffer that is not well-formed")
1021
1022 ;;; Debugging
1023
1024 (defun nxml-debug-overlays ()
1025   (interactive)
1026   (let ((overlays (nreverse (overlays-in (point-min) (point-max))))
1027         overlay)
1028     (while overlays
1029       (setq overlay (car overlays))
1030       (setq overlays (cdr overlays))
1031       (when (overlay-get overlay 'nxml-outline-display)
1032         (message "overlay %s: %s...%s (%s)"
1033                  (overlay-get overlay 'category)
1034                  (overlay-start overlay)
1035                  (overlay-end overlay)
1036                  (overlay-get overlay 'display))))))
1037
1038 (provide 'nxml-outln)
1039
1040 ;;; nxml-outln.el ends here