lisp/nxml/nxml-outln.el

   1 ;;; nxml-outln.el --- outline support for nXML mode
   2
   3 ;; Copyright (C) 2004, 2007-2012  Free Software Foundation, Inc.
   4
   5 ;; Author: James Clark
   6 ;; Keywords: XML
   7
   8 ;; This file is part of GNU Emacs.
   9
  10 ;; GNU Emacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  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-children 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
 113   '((t (:weight bold)))
 114   "Face used for the contents of abbreviated heading elements."
 115   :group 'nxml-faces)
 116
 117 (defface nxml-outline-indicator
 118   '((t (:inherit default)))
 119   "Face used for `+' or `-' before element names in outlines."
 120   :group 'nxml-faces)
 121
 122 (defface nxml-outline-active-indicator
 123   '((t (:box t :inherit nxml-outline-indicator)))
 124   "Face used for clickable `+' or `-' before element names in outlines."
 125   :group 'nxml-faces)
 126
 127 (defface nxml-outline-ellipsis
 128   '((t (:bold t :inherit default)))
 129   "Face used for `...' in outlines."
 130   :group 'nxml-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 (defsubst nxml-token-start-tag-p ()
 414   (or (eq xmltok-type 'start-tag)
 415       (eq xmltok-type 'partial-start-tag)))
 416
 417 (defsubst nxml-token-end-tag-p ()
 418   (or (eq xmltok-type 'end-tag)
 419       (eq xmltok-type 'partial-end-tag)))
 420
 421 (defun nxml-refresh-outline ()
 422   "Refresh the outline to correspond to the current XML element structure."
 423   (interactive)
 424   (save-excursion
 425     (goto-char (point-min))
 426     (kill-local-variable 'line-move-ignore-invisible)
 427     (make-local-variable 'line-move-ignore-invisible)
 428     (condition-case err
 429         (nxml-outline-display-rest nil nil nil)
 430       (nxml-outline-error
 431        (nxml-report-outline-error "Cannot display outline: %s" err)))))
 432
 433 (defvar nxml-outline-display-section-tag-function nil)
 434
 435 (defun nxml-outline-display-rest (outline-state start-tag-indent tag-qnames)
 436   "Display up to and including the end of the current element.
 437 OUTLINE-STATE can be nil, t, hide-children.  START-TAG-INDENT is the
 438 indent of the start-tag of the current element, or nil if no
 439 containing element has a non-nil OUTLINE-STATE.  TAG-QNAMES is a list
 440 of the qnames of the open elements.  Point is after the title content.
 441 Leave point after the closing end-tag.  Return t if we had a
 442 non-transparent child section."
 443   (let ((last-pos (point))
 444         (transparent-depth 0)
 445         ;; don't want ellipsis before root element
 446         (had-children (not tag-qnames)))
 447     (while
 448         (cond ((not (nxml-section-tag-forward))
 449                (if (null tag-qnames)
 450                    nil
 451                  (nxml-outline-error "missing end-tag %s"
 452                                      (car tag-qnames))))
 453               ;; section end-tag
 454               ((nxml-token-end-tag-p)
 455                (when nxml-outline-display-section-tag-function
 456                  (funcall nxml-outline-display-section-tag-function
 457                           nil
 458                           xmltok-start))
 459                (let ((qname (xmltok-end-tag-qname)))
 460                  (unless tag-qnames
 461                    (nxml-outline-error "extra end-tag %s" qname))
 462                  (unless (string= (car tag-qnames) qname)
 463                    (nxml-outline-error "mismatched end-tag; expected %s, got %s"
 464                                        (car tag-qnames)
 465                                        qname)))
 466                (cond ((> transparent-depth 0)
 467                       (setq transparent-depth (1- transparent-depth))
 468                       (setq tag-qnames (cdr tag-qnames))
 469                       t)
 470                      ((not outline-state)
 471                       (nxml-outline-set-overlay nil last-pos (point))
 472                       nil)
 473                      ((or (not had-children)
 474                           (eq outline-state 'hide-children))
 475                       (nxml-outline-display-single-line-end-tag last-pos)
 476                       nil)
 477                      (t
 478                       (nxml-outline-display-multi-line-end-tag last-pos
 479                                                                start-tag-indent)
 480                       nil)))
 481               ;; section start-tag
 482               (t
 483                (let* ((qname (xmltok-start-tag-qname))
 484                       (section-start-pos xmltok-start)
 485                       (heading-start-pos
 486                        (and (or nxml-outline-display-section-tag-function
 487                                 (not (eq outline-state 'had-children))
 488                                 (not had-children))
 489                             (nxml-token-starts-line-p)
 490                             (nxml-heading-start-position))))
 491                  (when nxml-outline-display-section-tag-function
 492                    (funcall nxml-outline-display-section-tag-function
 493                             t
 494                             section-start-pos
 495                             heading-start-pos))
 496                  (setq tag-qnames (cons qname tag-qnames))
 497                  (if (or (not heading-start-pos)
 498                          (and (eq outline-state 'hide-children)
 499                               (setq had-children t)))
 500                      (setq transparent-depth (1+ transparent-depth))
 501                    (nxml-display-section last-pos
 502                                          section-start-pos
 503                                          heading-start-pos
 504                                          start-tag-indent
 505                                          outline-state
 506                                          had-children
 507                                          tag-qnames)
 508                    (setq had-children t)
 509                    (setq tag-qnames (cdr tag-qnames))
 510                    (setq last-pos (point))))
 511                t)))
 512     had-children))
 513
 514 (defconst nxml-highlighted-less-than
 515   (propertize "<" 'face 'nxml-tag-delimiter))
 516
 517 (defconst nxml-highlighted-greater-than
 518   (propertize ">" 'face 'nxml-tag-delimiter))
 519
 520 (defconst nxml-highlighted-colon
 521   (propertize ":" 'face 'nxml-element-colon))
 522
 523 (defconst nxml-highlighted-slash
 524   (propertize "/" 'face 'nxml-tag-slash))
 525
 526 (defconst nxml-highlighted-ellipsis
 527   (propertize "..." 'face 'nxml-outline-ellipsis))
 528
 529 (defconst nxml-highlighted-empty-end-tag
 530   (concat nxml-highlighted-ellipsis
 531           nxml-highlighted-less-than
 532           nxml-highlighted-slash
 533           nxml-highlighted-greater-than))
 534
 535 (defconst nxml-highlighted-inactive-minus
 536   (propertize "-" 'face 'nxml-outline-indicator))
 537
 538 (defconst nxml-highlighted-active-minus
 539   (propertize "-" 'face 'nxml-outline-active-indicator))
 540
 541 (defconst nxml-highlighted-active-plus
 542   (propertize "+" 'face 'nxml-outline-active-indicator))
 543
 544 (defun nxml-display-section (last-pos
 545                              section-start-pos
 546                              heading-start-pos
 547                              parent-indent
 548                              parent-outline-state
 549                              had-children
 550                              tag-qnames)
 551   (let* ((section-start-pos-bol
 552           (save-excursion
 553             (goto-char section-start-pos)
 554             (skip-chars-backward " \t")
 555             (point)))
 556          (outline-state (nxml-get-outline-state section-start-pos))
 557          (newline-before-section-start-category
 558           (cond ((and (not had-children) parent-outline-state)
 559                  'nxml-outline-display-ellipsis)
 560                  (outline-state 'nxml-outline-display-show)
 561                  (t nil))))
 562     (nxml-outline-set-overlay (and parent-outline-state
 563                                    'nxml-outline-display-hide)
 564                               last-pos
 565                               (1- section-start-pos-bol)
 566                               nil
 567                               t)
 568     (if outline-state
 569       (let* ((indent (if parent-indent
 570                          (+ parent-indent nxml-outline-child-indent)
 571                        (save-excursion
 572                          (goto-char section-start-pos)
 573                          (current-column))))
 574              start-tag-overlay)
 575         (nxml-outline-set-overlay newline-before-section-start-category
 576                                   (1- section-start-pos-bol)
 577                                   section-start-pos-bol
 578                                   t)
 579         (nxml-outline-set-overlay 'nxml-outline-display-hide
 580                                   section-start-pos-bol
 581                                   section-start-pos)
 582         (setq start-tag-overlay
 583             (nxml-outline-set-overlay 'nxml-outline-display-show
 584                                       section-start-pos
 585                                       (1+ section-start-pos)
 586                                       t))
 587         ;; line motion commands don't work right if start-tag-overlay
 588         ;; covers multiple lines
 589         (nxml-outline-set-overlay 'nxml-outline-display-hide
 590                                   (1+ section-start-pos)
 591                                   heading-start-pos)
 592         (goto-char heading-start-pos)
 593         (nxml-end-of-heading)
 594         (nxml-outline-set-overlay 'nxml-outline-display-heading
 595                                   heading-start-pos
 596                                   (point))
 597         (let* ((had-children
 598                 (nxml-outline-display-rest outline-state
 599                                            indent
 600                                            tag-qnames)))
 601           (overlay-put start-tag-overlay
 602                        'display
 603                        (concat
 604                         ;; indent
 605                         (make-string indent ?\ )
 606                         ;; <
 607                         nxml-highlighted-less-than
 608                         ;; + or - indicator
 609                         (cond ((not had-children)
 610                                nxml-highlighted-inactive-minus)
 611                               ((eq outline-state 'hide-children)
 612                                (overlay-put start-tag-overlay
 613                                             'category
 614                                             'nxml-outline-display-hiding-tag)
 615                                nxml-highlighted-active-plus)
 616                               (t
 617                                (overlay-put start-tag-overlay
 618                                             'category
 619                                             'nxml-outline-display-showing-tag)
 620                                nxml-highlighted-active-minus))
 621                         ;; qname
 622                         (nxml-highlighted-qname (car tag-qnames))
 623                         ;; >
 624                         nxml-highlighted-greater-than))))
 625       ;; outline-state nil
 626       (goto-char heading-start-pos)
 627       (nxml-end-of-heading)
 628       (nxml-outline-set-overlay newline-before-section-start-category
 629                                 (1- section-start-pos-bol)
 630                                 (point)
 631                                 t)
 632       (nxml-outline-display-rest outline-state
 633                                  (and parent-indent
 634                                       (+ parent-indent
 635                                          nxml-outline-child-indent))
 636                                  tag-qnames))))
 637
 638 (defun nxml-highlighted-qname (qname)
 639   (let ((colon (string-match ":" qname)))
 640     (if colon
 641         (concat (propertize (substring qname 0 colon)
 642                             'face
 643                             'nxml-element-prefix)
 644                 nxml-highlighted-colon
 645                 (propertize (substring qname (1+ colon))
 646                             'face
 647                             'nxml-element-local-name))
 648       (propertize qname
 649                   'face
 650                   'nxml-element-local-name))))
 651
 652 (defun nxml-outline-display-single-line-end-tag (last-pos)
 653   (nxml-outline-set-overlay 'nxml-outline-display-hide
 654                             last-pos
 655                             xmltok-start
 656                             nil
 657                             t)
 658   (overlay-put (nxml-outline-set-overlay 'nxml-outline-display-show
 659                                          xmltok-start
 660                                          (point)
 661                                          t)
 662                'display
 663                nxml-highlighted-empty-end-tag))
 664
 665 (defun nxml-outline-display-multi-line-end-tag (last-pos start-tag-indent)
 666   (let ((indentp (save-excursion
 667                    (goto-char last-pos)
 668                    (skip-chars-forward " \t")
 669                    (and (eq (char-after) ?\n)
 670                         (progn
 671                           (goto-char (1+ (point)))
 672                           (nxml-outline-set-overlay nil last-pos (point))
 673                           (setq last-pos (point))
 674                           (goto-char xmltok-start)
 675                           (beginning-of-line)
 676                           t))))
 677         end-tag-overlay)
 678     (nxml-outline-set-overlay 'nxml-outline-display-hide
 679                               last-pos
 680                               xmltok-start
 681                               nil
 682                               t)
 683     (setq end-tag-overlay
 684           (nxml-outline-set-overlay 'nxml-outline-display-showing-tag
 685                                     xmltok-start
 686                                     (point)
 687                                     t))
 688     (overlay-put end-tag-overlay
 689                  'display
 690                  (concat (if indentp
 691                              (make-string start-tag-indent ?\ )
 692                            "")
 693                          nxml-highlighted-less-than
 694                          nxml-highlighted-slash
 695                          nxml-highlighted-active-minus
 696                          (nxml-highlighted-qname (xmltok-end-tag-qname))
 697                          nxml-highlighted-greater-than))))
 698
 699 (defvar nxml-outline-show-map
 700   (let ((map (make-sparse-keymap)))
 701     (define-key map "\C-m" 'nxml-show-direct-text-content)
 702     (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content)
 703     map))
 704
 705 (defvar nxml-outline-show-help "mouse-2: show")
 706
 707 (put 'nxml-outline-display-show 'nxml-outline-display t)
 708 (put 'nxml-outline-display-show 'evaporate t)
 709 (put 'nxml-outline-display-show 'keymap nxml-outline-show-map)
 710 (put 'nxml-outline-display-show 'help-echo nxml-outline-show-help)
 711
 712 (put 'nxml-outline-display-hide 'nxml-outline-display t)
 713 (put 'nxml-outline-display-hide 'evaporate t)
 714 (put 'nxml-outline-display-hide 'invisible t)
 715 (put 'nxml-outline-display-hide 'keymap nxml-outline-show-map)
 716 (put 'nxml-outline-display-hide 'help-echo nxml-outline-show-help)
 717
 718 (put 'nxml-outline-display-ellipsis 'nxml-outline-display t)
 719 (put 'nxml-outline-display-ellipsis 'evaporate t)
 720 (put 'nxml-outline-display-ellipsis 'keymap nxml-outline-show-map)
 721 (put 'nxml-outline-display-ellipsis 'help-echo nxml-outline-show-help)
 722 (put 'nxml-outline-display-ellipsis 'before-string nxml-highlighted-ellipsis)
 723
 724 (put 'nxml-outline-display-heading 'keymap nxml-outline-show-map)
 725 (put 'nxml-outline-display-heading 'help-echo nxml-outline-show-help)
 726 (put 'nxml-outline-display-heading 'nxml-outline-display t)
 727 (put 'nxml-outline-display-heading 'evaporate t)
 728 (put 'nxml-outline-display-heading 'face 'nxml-heading)
 729
 730 (defvar nxml-outline-hiding-tag-map
 731   (let ((map (make-sparse-keymap)))
 732     (define-key map [mouse-1] 'nxml-mouse-show-direct-subheadings)
 733     (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content)
 734     (define-key map "\C-m" 'nxml-show-direct-text-content)
 735     map))
 736
 737 (defvar nxml-outline-hiding-tag-help
 738   "mouse-1: show subheadings, mouse-2: show text content")
 739
 740 (put 'nxml-outline-display-hiding-tag 'nxml-outline-display t)
 741 (put 'nxml-outline-display-hiding-tag 'evaporate t)
 742 (put 'nxml-outline-display-hiding-tag 'keymap nxml-outline-hiding-tag-map)
 743 (put 'nxml-outline-display-hiding-tag 'help-echo nxml-outline-hiding-tag-help)
 744
 745 (defvar nxml-outline-showing-tag-map
 746   (let ((map (make-sparse-keymap)))
 747     (define-key map [mouse-1] 'nxml-mouse-hide-subheadings)
 748     (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content)
 749     (define-key map "\C-m" 'nxml-show-direct-text-content)
 750     map))
 751
 752 (defvar nxml-outline-showing-tag-help
 753   "mouse-1: hide subheadings, mouse-2: show text content")
 754
 755 (put 'nxml-outline-display-showing-tag 'nxml-outline-display t)
 756 (put 'nxml-outline-display-showing-tag 'evaporate t)
 757 (put 'nxml-outline-display-showing-tag 'keymap nxml-outline-showing-tag-map)
 758 (put 'nxml-outline-display-showing-tag
 759      'help-echo
 760      nxml-outline-showing-tag-help)
 761
 762 (defun nxml-outline-set-overlay (category
 763                                  start
 764                                  end
 765                                  &optional
 766                                  front-advance
 767                                  rear-advance)
 768   "Replace any `nxml-outline-display' overlays between START and END.
 769 Overlays are removed if they overlay the region between START and END,
 770 and have a non-nil `nxml-outline-display' property (typically via their
 771 category).  If CATEGORY is non-nil, they will be replaced with a new
 772 overlay with that category from START to END.  If CATEGORY is nil,
 773 no new overlay will be created."
 774   (when (< start end)
 775     (let ((overlays (overlays-in start end))
 776           overlay)
 777       (while overlays
 778         (setq overlay (car overlays))
 779         (setq overlays (cdr overlays))
 780         (when (overlay-get overlay 'nxml-outline-display)
 781           (delete-overlay overlay))))
 782     (and category
 783          (let ((overlay (make-overlay start
 784                                       end
 785                                       nil
 786                                       front-advance
 787                                       rear-advance)))
 788            (overlay-put overlay 'category category)
 789            (setq line-move-ignore-invisible t)
 790            overlay))))
 791
 792 (defun nxml-end-of-heading ()
 793   "Move from the start of the content of the heading to the end.
 794 Do not move past the end of the line."
 795   (let ((pos (condition-case err
 796                  (and (nxml-scan-element-forward (point) t)
 797                       xmltok-start)
 798                (nxml-scan-error nil))))
 799     (end-of-line)
 800     (skip-chars-backward " \t")
 801     (cond ((not pos)
 802            (setq pos (nxml-token-before))
 803            (when (eq xmltok-type 'end-tag)
 804              (goto-char pos)))
 805           ((< pos (point))
 806            (goto-char pos)))
 807     (skip-chars-backward " \t")
 808     (point)))
 809
 810 ;;; Navigating section structure
 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