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