code.delx.au - gnu-emacs/blob - lisp/nxml/nxml-outln.el

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