lisp/nxml/nxml-outln.el

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