[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] Changes to lisp/nxml/nxml-outln.el
|
From: |
Mark A. Hershberger |
|
Subject: |
[Emacs-diffs] Changes to lisp/nxml/nxml-outln.el |
|
Date: |
Fri, 23 Nov 2007 06:58:17 +0000 |
CVSROOT: /sources/emacs
Module name: emacs
Changes by: Mark A. Hershberger <hexmode> 07/11/23 06:58:00
Index: lisp/nxml/nxml-outln.el
===================================================================
RCS file: lisp/nxml/nxml-outln.el
diff -N lisp/nxml/nxml-outln.el
--- /dev/null 1 Jan 1970 00:00:00 -0000
+++ lisp/nxml/nxml-outln.el 23 Nov 2007 06:57:50 -0000 1.1
@@ -0,0 +1,1040 @@
+;;; nxml-outln.el --- outline support for nXML mode
+
+;; Copyright (C) 2004 Free Software Foundation, Inc.
+
+;; Author: James Clark
+;; Keywords: XML
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be
+;; useful, but WITHOUT ANY WARRANTY; without even the implied
+;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE. See the GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public
+;; License along with this program; if not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
+;; MA 02111-1307 USA
+
+;;; Commentary:
+
+;; A section can be in one of three states
+;; 1. display normally; this displays each child section
+;; according to its state; anything not part of child sections is also
+;; displayed normally
+;; 2. display just the title specially; child sections are not displayed
+;; regardless of their state; anything not part of child sections is
+;; not displayed
+;; 3. display the title specially and display child sections
+;; according to their state; anything not part of the child section is
+;; not displayed
+;; The state of a section is determined by the value of the
+;; nxml-outline-state text property of the < character that starts
+;; the section.
+;; For state 1 the value is nil or absent.
+;; For state 2 it is the symbol hide-children.
+;; For state 3 it is t.
+;; The special display is achieved by using overlays. The overlays
+;; are computed from the nxml-outline-state property by
+;; `nxml-refresh-outline'. There overlays all have a category property
+;; with an nxml-outline-display property with value t.
+;;
+;; For a section to be recognized as such, the following conditions must
+;; be satisfied:
+;; - its start-tag must occur at the start of a line (possibly indented)
+;; - its local name must match `nxml-section-element-name-regexp'
+;; - it must have a heading element; a heading element is an
+;; element whose name matches `nxml-heading-element-name-regexp',
+;; and that occurs as, or as a descendant of, the first child element
+;; of the section
+;;
+;; XXX What happens if an nxml-outline-state property is attached to a
+;; character that doesn't start a section element?
+;;
+;; An outlined section (an section with a non-nil nxml-outline-state
+;; property) can be displayed in either single-line or multi-line
+;; form. Single-line form is used when the outline state is hide-children
+;; or there are no child sections; multi-line form is used otherwise.
+;; There are two flavors of single-line form: with children and without.
+;; The with-childen flavor is used when there are child sections.
+;; Single line with children looks like
+;; <+section>A section title...</>
+;; Single line without children looks like
+;; <-section>A section title...</>
+;; Multi line looks likes
+;; <-section>A section title...
+;; [child sections displayed here]
+;; </-section>
+;; The indent of an outlined section is computed relative to the
+;; outermost containing outlined element. The indent of the
+;; outermost containing element comes from the non-outlined
+;; indent of the section start-tag.
+
+;;; Code:
+
+(require 'xmltok)
+(require 'nxml-util)
+(require 'nxml-rap)
+
+(defcustom nxml-section-element-name-regexp
+
"article\\|\\(sub\\)*section\\|chapter\\|div\\|appendix\\|part\\|preface\\|reference\\|simplesect\\|bibliography\\|bibliodiv\\|glossary\\|glossdiv"
+ "*Regular expression matching the name of elements used as sections.
+An XML element is treated as a section if:
+
+- its local name (that is, the name without the prefix) matches
+this regexp;
+
+- either its first child element or a descendant of that first child
+element has a local name matching the variable
+`nxml-heading-element-name-regexp'; and
+
+- its start-tag occurs at the beginning of a line (possibly indented)."
+ :group 'nxml
+ :type 'regexp)
+
+(defcustom nxml-heading-element-name-regexp "title\\|head"
+ "*Regular expression matching the name of elements used as headings.
+An XML element is only recognized as a heading if it occurs as or
+within the first child of an element that is recognized as a section.
+See the variable `nxml-section-element-name-regexp' for more details."
+ :group 'nxml
+ :type 'regexp)
+
+(defcustom nxml-outline-child-indent 2
+ "*Indentation in an outline for child element relative to parent element."
+ :group 'nxml
+ :type 'integer)
+
+(defface nxml-heading-face
+ '((t (:weight bold)))
+ "Face used for the contents of abbreviated heading elements."
+ :group 'nxml-highlighting-faces)
+
+(defface nxml-outline-indicator-face
+ '((t (:inherit default)))
+ "Face used for `+' or `-' before element names in outlines."
+ :group 'nxml-highlighting-faces)
+
+(defface nxml-outline-active-indicator-face
+ '((t (:box t :inherit nxml-outline-indicator-face)))
+ "Face used for clickable `+' or `-' before element names in outlines."
+ :group 'nxml-highlighting-faces)
+
+(defface nxml-outline-ellipsis-face
+ '((t (:bold t :inherit default)))
+ "Face used for `...' in outlines."
+ :group 'nxml-highlighting-faces)
+
+(defvar nxml-heading-scan-distance 1000
+ "Maximum distance from section to scan for heading.")
+
+(defvar nxml-outline-prefix-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-a" 'nxml-show-all)
+ (define-key map "\C-t" 'nxml-hide-all-text-content)
+ (define-key map "\C-r" 'nxml-refresh-outline)
+ (define-key map "\C-c" 'nxml-hide-direct-text-content)
+ (define-key map "\C-e" 'nxml-show-direct-text-content)
+ (define-key map "\C-d" 'nxml-hide-subheadings)
+ (define-key map "\C-s" 'nxml-show)
+ (define-key map "\C-k" 'nxml-show-subheadings)
+ (define-key map "\C-l" 'nxml-hide-text-content)
+ (define-key map "\C-i" 'nxml-show-direct-subheadings)
+ (define-key map "\C-o" 'nxml-hide-other)
+ map))
+
+;;; Commands for changing visibility
+
+(defun nxml-show-all ()
+ "Show all elements in the buffer normally."
+ (interactive)
+ (nxml-with-unmodifying-text-property-changes
+ (remove-text-properties (point-min)
+ (point-max)
+ '(nxml-outline-state nil)))
+ (nxml-outline-set-overlay nil (point-min) (point-max)))
+
+(defun nxml-hide-all-text-content ()
+ "Hide all text content in the buffer.
+Anything that is in a section but is not a heading will be hidden.
+The visibility of headings at any level will not be changed. See the
+variable `nxml-section-element-name-regexp' for more details on how to
+customize which elements are recognized as sections and headings."
+ (interactive)
+ (nxml-transform-buffer-outline '((nil . t))))
+
+(defun nxml-show-direct-text-content ()
+ "Show the text content that is directly part of the section containing point.
+Each subsection will be shown according to its individual state, which
+will not be changed. The section containing point is the innermost
+section that contains the character following point. See the variable
+`nxml-section-element-name-regexp' for more details on how to
+customize which elements are recognized as sections and headings."
+ (interactive)
+ (nxml-outline-pre-adjust-point)
+ (nxml-set-outline-state (nxml-section-start-position) nil)
+ (nxml-refresh-outline)
+ (nxml-outline-adjust-point))
+
+(defun nxml-show-direct-subheadings ()
+ "Show the immediate subheadings of the section containing point.
+The section containing point is the innermost section that contains
+the character following point. See the variable
+`nxml-section-element-name-regexp' for more details on how to
+customize which elements are recognized as sections and headings."
+ (interactive)
+ (let ((pos (nxml-section-start-position)))
+ (when (eq (nxml-get-outline-state pos) 'hide-children)
+ (nxml-set-outline-state pos t)))
+ (nxml-refresh-outline)
+ (nxml-outline-adjust-point))
+
+(defun nxml-hide-direct-text-content ()
+ "Hide the text content that is directly part of the section containing point.
+The heading of the section will remain visible. The state of
+subsections will not be changed. The section containing point is the
+innermost section that contains the character following point. See the
+variable `nxml-section-element-name-regexp' for more details on how to
+customize which elements are recognized as sections and headings."
+ (interactive)
+ (let ((pos (nxml-section-start-position)))
+ (when (null (nxml-get-outline-state pos))
+ (nxml-set-outline-state pos t)))
+ (nxml-refresh-outline)
+ (nxml-outline-adjust-point))
+
+(defun nxml-hide-subheadings ()
+ "Hide the subheadings that are part of the section containing point.
+The text content will also be hidden, leaving only the heading of the
+section itself visible. The state of the subsections will also be
+changed to hide their headings, so that \\[nxml-show-direct-text-content]
+would show only the heading of the subsections. The section containing
+point is the innermost section that contains the character following
+point. See the variable `nxml-section-element-name-regexp' for more
+details on how to customize which elements are recognized as sections
+and headings."
+ (interactive)
+ (nxml-transform-subtree-outline '((nil . hide-children)
+ (t . hide-children))))
+
+(defun nxml-show ()
+ "Show the section containing point normally, without hiding anything.
+This includes everything in the section at any level. The section
+containing point is the innermost section that contains the character
+following point. See the variable `nxml-section-element-name-regexp'
+for more details on how to customize which elements are recognized as
+sections and headings."
+ (interactive)
+ (nxml-transform-subtree-outline '((hide-children . nil)
+ (t . nil))))
+
+(defun nxml-hide-text-content ()
+ "Hide text content at all levels in the section containing point.
+The section containing point is the innermost section that contains
+the character following point. See the variable
+`nxml-section-element-name-regexp' for more details on how to
+customize which elements are recognized as sections and headings."
+ (interactive)
+ (nxml-transform-subtree-outline '((nil . t))))
+
+(defun nxml-show-subheadings ()
+ "Show the subheadings at all levels of the section containing point.
+The visibility of the text content at all levels in the section is not
+changed. The section containing point is the innermost section that
+contains the character following point. See the variable
+`nxml-section-element-name-regexp' for more details on how to
+customize which elements are recognized as sections and headings."
+ (interactive)
+ (nxml-transform-subtree-outline '((hide-children . t))))
+
+(defun nxml-hide-other ()
+ "Hide text content other than that directly in the section containing point.
+Hide headings other than those of ancestors of that section and their
+immediate subheadings. The section containing point is the innermost
+section that contains the character following point. See the variable
+`nxml-section-element-name-regexp' for more details on how to
+customize which elements are recognized as sections and headings."
+ (interactive)
+ (let ((nxml-outline-state-transform-exceptions nil))
+ (save-excursion
+ (while (and (condition-case err
+ (nxml-back-to-section-start)
+ (nxml-outline-error (nxml-report-outline-error
+ "Couldn't find containing section: %s"
+ err)))
+ (progn
+ (when (and nxml-outline-state-transform-exceptions
+ (null (nxml-get-outline-state (point))))
+ (nxml-set-outline-state (point) t))
+ (setq nxml-outline-state-transform-exceptions
+ (cons (point)
+ nxml-outline-state-transform-exceptions))
+ (< nxml-prolog-end (point))))
+ (goto-char (1- (point)))))
+ (nxml-transform-buffer-outline '((nil . hide-children)
+ (t . hide-children)))))
+
+;; These variables are dynamically bound. They are use to pass information to
+;; nxml-section-tag-transform-outline-state.
+
+(defvar nxml-outline-state-transform-exceptions nil)
+(defvar nxml-target-section-pos nil)
+(defvar nxml-depth-in-target-section nil)
+(defvar nxml-outline-state-transform-alist nil)
+
+(defun nxml-transform-buffer-outline (alist)
+ (let ((nxml-target-section-pos nil)
+ (nxml-depth-in-target-section 0)
+ (nxml-outline-state-transform-alist alist)
+ (nxml-outline-display-section-tag-function
+ 'nxml-section-tag-transform-outline-state))
+ (nxml-refresh-outline))
+ (nxml-outline-adjust-point))
+
+(defun nxml-transform-subtree-outline (alist)
+ (let ((nxml-target-section-pos (nxml-section-start-position))
+ (nxml-depth-in-target-section nil)
+ (nxml-outline-state-transform-alist alist)
+ (nxml-outline-display-section-tag-function
+ 'nxml-section-tag-transform-outline-state))
+ (nxml-refresh-outline))
+ (nxml-outline-adjust-point))
+
+(defun nxml-outline-pre-adjust-point ()
+ (cond ((and (< (point-min) (point))
+ (get-char-property (1- (point)) 'invisible)
+ (not (get-char-property (point) 'invisible))
+ (let ((str (or (get-char-property (point) 'before-string)
+ (get-char-property (point) 'display))))
+ (and (stringp str)
+ (>= (length str) 3)
+ (string= (substring str 0 3) "..."))))
+ ;; The ellipsis is a display property on a visible character
+ ;; following an invisible region. The position of the event
+ ;; will be the position before that character. We want to
+ ;; move point to the other side of the invisible region, i.e.
+ ;; following the last visible character before that invisible
+ ;; region.
+ (goto-char (previous-single-char-property-change (1- (point))
+ 'invisible)))
+ ((and (< (point) (point-max))
+ (get-char-property (point) 'display)
+ (get-char-property (1+ (point)) 'invisible))
+ (goto-char (next-single-char-property-change (1+ (point))
+ 'invisible)))
+ ((and (< (point) (point-max))
+ (get-char-property (point) 'invisible))
+ (goto-char (next-single-char-property-change (point)
+ 'invisible)))))
+
+(defun nxml-outline-adjust-point ()
+ "Adjust point after showing or hiding elements."
+ (when (and (get-char-property (point) 'invisible)
+ (< (point-min) (point))
+ (get-char-property (1- (point)) 'invisible))
+ (goto-char (previous-single-char-property-change (point)
+ 'invisible
+ nil
+ nxml-prolog-end))))
+
+(defun nxml-transform-outline-state (section-start-pos)
+ (let* ((old-state
+ (nxml-get-outline-state section-start-pos))
+ (change (assq old-state
+ nxml-outline-state-transform-alist)))
+ (when change
+ (nxml-set-outline-state section-start-pos
+ (cdr change)))))
+
+(defun nxml-section-tag-transform-outline-state (startp
+ section-start-pos
+ &optional
+ heading-start-pos)
+ (if (not startp)
+ (setq nxml-depth-in-target-section
+ (and nxml-depth-in-target-section
+ (> nxml-depth-in-target-section 0)
+ (1- nxml-depth-in-target-section)))
+ (cond (nxml-depth-in-target-section
+ (setq nxml-depth-in-target-section
+ (1+ nxml-depth-in-target-section)))
+ ((= section-start-pos nxml-target-section-pos)
+ (setq nxml-depth-in-target-section 0)))
+ (when (and nxml-depth-in-target-section
+ (not (member section-start-pos
+ nxml-outline-state-transform-exceptions)))
+ (nxml-transform-outline-state section-start-pos))))
+
+(defun nxml-get-outline-state (pos)
+ (get-text-property pos 'nxml-outline-state))
+
+(defun nxml-set-outline-state (pos state)
+ (nxml-with-unmodifying-text-property-changes
+ (if state
+ (put-text-property pos (1+ pos) 'nxml-outline-state state)
+ (remove-text-properties pos (1+ pos) '(nxml-outline-state nil)))))
+
+;;; Mouse interface
+
+(defun nxml-mouse-show-direct-text-content (event)
+ "Do the same as \\[nxml-show-direct-text-content] from a mouse click."
+ (interactive "e")
+ (and (nxml-mouse-set-point event)
+ (nxml-show-direct-text-content)))
+
+(defun nxml-mouse-hide-direct-text-content (event)
+ "Do the same as \\[nxml-hide-direct-text-content] from a mouse click."
+ (interactive "e")
+ (and (nxml-mouse-set-point event)
+ (nxml-hide-direct-text-content)))
+
+(defun nxml-mouse-hide-subheadings (event)
+ "Do the same as \\[nxml-hide-subheadings] from a mouse click."
+ (interactive "e")
+ (and (nxml-mouse-set-point event)
+ (nxml-hide-subheadings)))
+
+(defun nxml-mouse-show-direct-subheadings (event)
+ "Do the same as \\[nxml-show-direct-subheadings] from a mouse click."
+ (interactive "e")
+ (and (nxml-mouse-set-point event)
+ (nxml-show-direct-subheadings)))
+
+(defun nxml-mouse-set-point (event)
+ (mouse-set-point event)
+ (and nxml-prolog-end t))
+
+;; Display
+
+(defun nxml-refresh-outline ()
+ "Refresh the outline to correspond to the current XML element structure."
+ (interactive)
+ (save-excursion
+ (goto-char (point-min))
+ (kill-local-variable 'line-move-ignore-invisible)
+ (make-local-variable 'line-move-ignore-invisible)
+ (condition-case err
+ (nxml-outline-display-rest nil nil nil)
+ (nxml-outline-error
+ (nxml-report-outline-error "Cannot display outline: %s" err)))))
+
+(defvar nxml-outline-display-section-tag-function nil)
+
+(defun nxml-outline-display-rest (outline-state start-tag-indent tag-qnames)
+ "Display up to and including the end of the current element.
+OUTLINE-STATE can be nil, t, hide-children. START-TAG-INDENT is the
+indent of the start-tag of the current element, or nil if no
+containing element has a non-nil OUTLINE-STATE. TAG-QNAMES is a list
+of the qnames of the open elements. Point is after the title content.
+Leave point after the closing end-tag Return t if we had a
+non-transparent child section."
+ (let ((last-pos (point))
+ (transparent-depth 0)
+ ;; don't want ellipsis before root element
+ (had-children (not tag-qnames)))
+ (while
+ (cond ((not (nxml-section-tag-forward))
+ (if (null tag-qnames)
+ nil
+ (nxml-outline-error "missing end-tag %s"
+ (car tag-qnames))))
+ ;; section end-tag
+ ((nxml-token-end-tag-p)
+ (when nxml-outline-display-section-tag-function
+ (funcall nxml-outline-display-section-tag-function
+ nil
+ xmltok-start))
+ (let ((qname (xmltok-end-tag-qname)))
+ (unless tag-qnames
+ (nxml-outline-error "extra end-tag %s" qname))
+ (unless (string= (car tag-qnames) qname)
+ (nxml-outline-error "mismatched end-tag; expected %s, got %s"
+ (car tag-qnames)
+ qname)))
+ (cond ((> transparent-depth 0)
+ (setq transparent-depth (1- transparent-depth))
+ (setq tag-qnames (cdr tag-qnames))
+ t)
+ ((not outline-state)
+ (nxml-outline-set-overlay nil last-pos (point))
+ nil)
+ ((or (not had-children)
+ (eq outline-state 'hide-children))
+ (nxml-outline-display-single-line-end-tag last-pos)
+ nil)
+ (t
+ (nxml-outline-display-multi-line-end-tag last-pos
+ start-tag-indent)
+ nil)))
+ ;; section start-tag
+ (t
+ (let* ((qname (xmltok-start-tag-qname))
+ (section-start-pos xmltok-start)
+ (heading-start-pos
+ (and (or nxml-outline-display-section-tag-function
+ (not (eq outline-state 'had-children))
+ (not had-children))
+ (nxml-token-starts-line-p)
+ (nxml-heading-start-position))))
+ (when nxml-outline-display-section-tag-function
+ (funcall nxml-outline-display-section-tag-function
+ t
+ section-start-pos
+ heading-start-pos))
+ (setq tag-qnames (cons qname tag-qnames))
+ (if (or (not heading-start-pos)
+ (and (eq outline-state 'hide-children)
+ (setq had-children t)))
+ (setq transparent-depth (1+ transparent-depth))
+ (nxml-display-section last-pos
+ section-start-pos
+ heading-start-pos
+ start-tag-indent
+ outline-state
+ had-children
+ tag-qnames)
+ (setq had-children t)
+ (setq tag-qnames (cdr tag-qnames))
+ (setq last-pos (point))))
+ t)))
+ had-children))
+
+(defconst nxml-highlighted-less-than
+ (propertize "<" 'face 'nxml-tag-delimiter-face))
+
+(defconst nxml-highlighted-greater-than
+ (propertize ">" 'face 'nxml-tag-delimiter-face))
+
+(defconst nxml-highlighted-colon
+ (propertize ":" 'face 'nxml-element-colon-face))
+
+(defconst nxml-highlighted-slash
+ (propertize "/" 'face 'nxml-tag-slash-face))
+
+(defconst nxml-highlighted-ellipsis
+ (propertize "..." 'face 'nxml-outline-ellipsis-face))
+
+(defconst nxml-highlighted-empty-end-tag
+ (concat nxml-highlighted-ellipsis
+ nxml-highlighted-less-than
+ nxml-highlighted-slash
+ nxml-highlighted-greater-than))
+
+(defconst nxml-highlighted-inactive-minus
+ (propertize "-" 'face 'nxml-outline-indicator-face))
+
+(defconst nxml-highlighted-active-minus
+ (propertize "-" 'face 'nxml-outline-active-indicator-face))
+
+(defconst nxml-highlighted-active-plus
+ (propertize "+" 'face 'nxml-outline-active-indicator-face))
+
+(defun nxml-display-section (last-pos
+ section-start-pos
+ heading-start-pos
+ parent-indent
+ parent-outline-state
+ had-children
+ tag-qnames)
+ (let* ((section-start-pos-bol
+ (save-excursion
+ (goto-char section-start-pos)
+ (skip-chars-backward " \t")
+ (point)))
+ (outline-state (nxml-get-outline-state section-start-pos))
+ (newline-before-section-start-category
+ (cond ((and (not had-children) parent-outline-state)
+ 'nxml-outline-display-ellipsis)
+ (outline-state 'nxml-outline-display-show)
+ (t nil))))
+ (nxml-outline-set-overlay (and parent-outline-state
+ 'nxml-outline-display-hide)
+ last-pos
+ (1- section-start-pos-bol)
+ nil
+ t)
+ (if outline-state
+ (let* ((indent (if parent-indent
+ (+ parent-indent nxml-outline-child-indent)
+ (save-excursion
+ (goto-char section-start-pos)
+ (current-column))))
+ start-tag-overlay)
+ (nxml-outline-set-overlay newline-before-section-start-category
+ (1- section-start-pos-bol)
+ section-start-pos-bol
+ t)
+ (nxml-outline-set-overlay 'nxml-outline-display-hide
+ section-start-pos-bol
+ section-start-pos)
+ (setq start-tag-overlay
+ (nxml-outline-set-overlay 'nxml-outline-display-show
+ section-start-pos
+ (1+ section-start-pos)
+ t))
+ ;; line motion commands don't work right if start-tag-overlay
+ ;; covers multiple lines
+ (nxml-outline-set-overlay 'nxml-outline-display-hide
+ (1+ section-start-pos)
+ heading-start-pos)
+ (goto-char heading-start-pos)
+ (nxml-end-of-heading)
+ (nxml-outline-set-overlay 'nxml-outline-display-heading
+ heading-start-pos
+ (point))
+ (let* ((had-children
+ (nxml-outline-display-rest outline-state
+ indent
+ tag-qnames)))
+ (overlay-put start-tag-overlay
+ 'display
+ (concat
+ ;; indent
+ (make-string indent ?\ )
+ ;; <
+ nxml-highlighted-less-than
+ ;; + or - indicator
+ (cond ((not had-children)
+ nxml-highlighted-inactive-minus)
+ ((eq outline-state 'hide-children)
+ (overlay-put start-tag-overlay
+ 'category
+ 'nxml-outline-display-hiding-tag)
+ nxml-highlighted-active-plus)
+ (t
+ (overlay-put start-tag-overlay
+ 'category
+ 'nxml-outline-display-showing-tag)
+ nxml-highlighted-active-minus))
+ ;; qname
+ (nxml-highlighted-qname (car tag-qnames))
+ ;; >
+ nxml-highlighted-greater-than))))
+ ;; outline-state nil
+ (goto-char heading-start-pos)
+ (nxml-end-of-heading)
+ (nxml-outline-set-overlay newline-before-section-start-category
+ (1- section-start-pos-bol)
+ (point)
+ t)
+ (nxml-outline-display-rest outline-state
+ (and parent-indent
+ (+ parent-indent
+ nxml-outline-child-indent))
+ tag-qnames))))
+
+(defun nxml-highlighted-qname (qname)
+ (let ((colon (string-match ":" qname)))
+ (if colon
+ (concat (propertize (substring qname 0 colon)
+ 'face
+ 'nxml-element-prefix-face)
+ nxml-highlighted-colon
+ (propertize (substring qname (1+ colon))
+ 'face
+ 'nxml-element-local-name-face))
+ (propertize qname
+ 'face
+ 'nxml-element-local-name-face))))
+
+(defun nxml-outline-display-single-line-end-tag (last-pos)
+ (nxml-outline-set-overlay 'nxml-outline-display-hide
+ last-pos
+ xmltok-start
+ nil
+ t)
+ (overlay-put (nxml-outline-set-overlay 'nxml-outline-display-show
+ xmltok-start
+ (point)
+ t)
+ 'display
+ nxml-highlighted-empty-end-tag))
+
+(defun nxml-outline-display-multi-line-end-tag (last-pos start-tag-indent)
+ (let ((indentp (save-excursion
+ (goto-char last-pos)
+ (skip-chars-forward " \t")
+ (and (eq (char-after) ?\n)
+ (progn
+ (goto-char (1+ (point)))
+ (nxml-outline-set-overlay nil last-pos (point))
+ (setq last-pos (point))
+ (goto-char xmltok-start)
+ (beginning-of-line)
+ t))))
+ end-tag-overlay)
+ (nxml-outline-set-overlay 'nxml-outline-display-hide
+ last-pos
+ xmltok-start
+ nil
+ t)
+ (setq end-tag-overlay
+ (nxml-outline-set-overlay 'nxml-outline-display-showing-tag
+ xmltok-start
+ (point)
+ t))
+ (overlay-put end-tag-overlay
+ 'display
+ (concat (if indentp
+ (make-string start-tag-indent ?\ )
+ "")
+ nxml-highlighted-less-than
+ nxml-highlighted-slash
+ nxml-highlighted-active-minus
+ (nxml-highlighted-qname (xmltok-end-tag-qname))
+ nxml-highlighted-greater-than))))
+
+(defvar nxml-outline-show-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map "\C-m" 'nxml-show-direct-text-content)
+ (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content)
+ map))
+
+(defvar nxml-outline-show-help "mouse-2: show")
+
+(put 'nxml-outline-display-show 'nxml-outline-display t)
+(put 'nxml-outline-display-show 'evaporate t)
+(put 'nxml-outline-display-show 'keymap nxml-outline-show-map)
+(put 'nxml-outline-display-show 'help-echo nxml-outline-show-help)
+
+(put 'nxml-outline-display-hide 'nxml-outline-display t)
+(put 'nxml-outline-display-hide 'evaporate t)
+(put 'nxml-outline-display-hide 'invisible t)
+(put 'nxml-outline-display-hide 'keymap nxml-outline-show-map)
+(put 'nxml-outline-display-hide 'help-echo nxml-outline-show-help)
+
+(put 'nxml-outline-display-ellipsis 'nxml-outline-display t)
+(put 'nxml-outline-display-ellipsis 'evaporate t)
+(put 'nxml-outline-display-ellipsis 'keymap nxml-outline-show-map)
+(put 'nxml-outline-display-ellipsis 'help-echo nxml-outline-show-help)
+(put 'nxml-outline-display-ellipsis 'before-string nxml-highlighted-ellipsis)
+
+(put 'nxml-outline-display-heading 'keymap nxml-outline-show-map)
+(put 'nxml-outline-display-heading 'help-echo nxml-outline-show-help)
+(put 'nxml-outline-display-heading 'nxml-outline-display t)
+(put 'nxml-outline-display-heading 'evaporate t)
+(put 'nxml-outline-display-heading 'face 'nxml-heading-face)
+
+(defvar nxml-outline-hiding-tag-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] 'nxml-mouse-show-direct-subheadings)
+ (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content)
+ (define-key map "\C-m" 'nxml-show-direct-text-content)
+ map))
+
+(defvar nxml-outline-hiding-tag-help
+ "mouse-1: show subheadings, mouse-2: show text content")
+
+(put 'nxml-outline-display-hiding-tag 'nxml-outline-display t)
+(put 'nxml-outline-display-hiding-tag 'evaporate t)
+(put 'nxml-outline-display-hiding-tag 'keymap nxml-outline-hiding-tag-map)
+(put 'nxml-outline-display-hiding-tag 'help-echo nxml-outline-hiding-tag-help)
+
+(defvar nxml-outline-showing-tag-map
+ (let ((map (make-sparse-keymap)))
+ (define-key map [mouse-1] 'nxml-mouse-hide-subheadings)
+ (define-key map [mouse-2] 'nxml-mouse-show-direct-text-content)
+ (define-key map "\C-m" 'nxml-show-direct-text-content)
+ map))
+
+(defvar nxml-outline-showing-tag-help
+ "mouse-1: hide subheadings, mouse-2: show text content")
+
+(put 'nxml-outline-display-showing-tag 'nxml-outline-display t)
+(put 'nxml-outline-display-showing-tag 'evaporate t)
+(put 'nxml-outline-display-showing-tag 'keymap nxml-outline-showing-tag-map)
+(put 'nxml-outline-display-showing-tag
+ 'help-echo
+ nxml-outline-showing-tag-help)
+
+(defun nxml-outline-set-overlay (category
+ start
+ end
+ &optional
+ front-advance
+ rear-advance)
+ "Replace any nxml-outline-display overlays between START and END.
+Overlays are removed if they overlay the region between START and END,
+and have a non-nil nxml-outline-display property (typically via their
+category). If CATEGORY is non-nil, they will be replaced with a new overlay
+with that category from START to END. If CATEGORY is nil, no new
+overlay will be created."
+ (when (< start end)
+ (let ((overlays (overlays-in start end))
+ overlay)
+ (while overlays
+ (setq overlay (car overlays))
+ (setq overlays (cdr overlays))
+ (when (overlay-get overlay 'nxml-outline-display)
+ (delete-overlay overlay))))
+ (and category
+ (let ((overlay (make-overlay start
+ end
+ nil
+ front-advance
+ rear-advance)))
+ (overlay-put overlay 'category category)
+ (setq line-move-ignore-invisible t)
+ overlay))))
+
+(defun nxml-end-of-heading ()
+ "Move from the start of the content of the heading to the end.
+Do not move past the end of the line."
+ (let ((pos (condition-case err
+ (and (nxml-scan-element-forward (point) t)
+ xmltok-start)
+ nil)))
+ (end-of-line)
+ (skip-chars-backward " \t")
+ (cond ((not pos)
+ (setq pos (nxml-token-before))
+ (when (eq xmltok-type 'end-tag)
+ (goto-char pos)))
+ ((< pos (point))
+ (goto-char pos)))
+ (skip-chars-backward " \t")
+ (point)))
+
+;;; Navigating section structure
+
+(defsubst nxml-token-start-tag-p ()
+ (or (eq xmltok-type 'start-tag)
+ (eq xmltok-type 'partial-start-tag)))
+
+(defsubst nxml-token-end-tag-p ()
+ (or (eq xmltok-type 'end-tag)
+ (eq xmltok-type 'partial-end-tag)))
+
+(defun nxml-token-starts-line-p ()
+ (save-excursion
+ (goto-char xmltok-start)
+ (skip-chars-backward " \t")
+ (bolp)))
+
+(defvar nxml-cached-section-tag-regexp nil)
+(defvar nxml-cached-section-element-name-regexp nil)
+
+(defsubst nxml-make-section-tag-regexp ()
+ (if (eq nxml-cached-section-element-name-regexp
+ nxml-section-element-name-regexp)
+ nxml-cached-section-tag-regexp
+ (nxml-make-section-tag-regexp-1)))
+
+(defun nxml-make-section-tag-regexp-1 ()
+ (setq nxml-cached-section-element-name-regexp nil)
+ (setq nxml-cached-section-tag-regexp
+ (concat "</?\\("
+ "\\(" xmltok-ncname-regexp ":\\)?"
+ nxml-section-element-name-regexp
+ "\\)[ \t\r\n>]"))
+ (setq nxml-cached-section-element-name-regexp
+ nxml-section-element-name-regexp)
+ nxml-cached-section-tag-regexp)
+
+(defun nxml-section-tag-forward ()
+ "Move forward past the first tag that is a section start- or end-tag.
+Return xmltok-type for tag.
+If no tag found, return nil and move to the end of the buffer."
+ (let ((case-fold-search nil)
+ (tag-regexp (nxml-make-section-tag-regexp))
+ match-end)
+ (when (< (point) nxml-prolog-end)
+ (goto-char nxml-prolog-end))
+ (while (cond ((not (re-search-forward tag-regexp nil 'move))
+ (setq xmltok-type nil)
+ nil)
+ ((progn
+ (goto-char (match-beginning 0))
+ (setq match-end (match-end 0))
+ (nxml-ensure-scan-up-to-date)
+ (let ((end (nxml-inside-end (point))))
+ (when end
+ (goto-char end)
+ t))))
+ ((progn
+ (xmltok-forward)
+ (and (memq xmltok-type '(start-tag
+ partial-start-tag
+ end-tag
+ partial-end-tag))
+ ;; just in case wildcard matched non-name chars
+ (= xmltok-name-end (1- match-end))))
+ nil)
+ (t))))
+ xmltok-type)
+
+(defun nxml-section-tag-backward ()
+ "Move backward to the end of a tag that is a section start- or end-tag.
+The position of the end of the tag must be <= point
+Point is at the end of the tag. `xmltok-start' is the start."
+ (let ((case-fold-search nil)
+ (start (point))
+ (tag-regexp (nxml-make-section-tag-regexp))
+ match-end)
+ (if (< (point) nxml-prolog-end)
+ (progn
+ (goto-char (point-min))
+ nil)
+ (while (cond ((not (re-search-backward tag-regexp
+ nxml-prolog-end
+ 'move))
+ (setq xmltok-type nil)
+ (goto-char (point-min))
+ nil)
+ ((progn
+ (goto-char (match-beginning 0))
+ (setq match-end (match-end 0))
+ (nxml-ensure-scan-up-to-date)
+ (let ((pos (nxml-inside-start (point))))
+ (when pos
+ (goto-char (1- pos))
+ t))))
+ ((progn
+ (xmltok-forward)
+ (and (<= (point) start)
+ (memq xmltok-type '(start-tag
+ partial-start-tag
+ end-tag
+ partial-end-tag))
+ ;; just in case wildcard matched non-name chars
+ (= xmltok-name-end (1- match-end))))
+ nil)
+ (t (goto-char xmltok-start)
+ t)))
+ xmltok-type)))
+
+(defun nxml-section-start-position ()
+ "Return the position of the start of the section containing point.
+Signal an error on failure."
+ (condition-case err
+ (save-excursion (if (nxml-back-to-section-start)
+ (point)
+ (error "Not in section")))
+ (nxml-outline-error
+ (nxml-report-outline-error "Couldn't determine containing section: %s"
+ err))))
+
+(defun nxml-back-to-section-start (&optional invisible-ok)
+ "Try to move back to the start of the section containing point.
+The start of the section must be <= point.
+Only visible sections are included unless INVISIBLE-OK is non-nil.
+If found, return t. Otherwise move to point-min and return nil.
+If unbalanced section tags are found, signal an `nxml-outline-error'."
+ (when (or (nxml-after-section-start-tag)
+ (nxml-section-tag-backward))
+ (let (open-tags found)
+ (while (let (section-start-pos)
+ (setq section-start-pos xmltok-start)
+ (if (nxml-token-end-tag-p)
+ (setq open-tags (cons (xmltok-end-tag-qname)
+ open-tags))
+ (if (not open-tags)
+ (when (and (nxml-token-starts-line-p)
+ (or invisible-ok
+ (not (get-char-property section-start-pos
+ 'invisible)))
+ (nxml-heading-start-position))
+ (setq found t))
+ (let ((qname (xmltok-start-tag-qname)))
+ (unless (string= (car open-tags) qname)
+ (nxml-outline-error "mismatched end-tag"))
+ (setq open-tags (cdr open-tags)))))
+ (goto-char section-start-pos)
+ (and (not found)
+ (nxml-section-tag-backward))))
+ found)))
+
+(defun nxml-after-section-start-tag ()
+ "If the character after point is in a section start-tag, move after it.
+Return the token type. Otherwise return nil.
+Set up variables like `xmltok-forward'."
+ (let ((pos (nxml-token-after))
+ (case-fold-search nil))
+ (when (and (memq xmltok-type '(start-tag partial-start-tag))
+ (save-excursion
+ (goto-char xmltok-start)
+ (looking-at (nxml-make-section-tag-regexp))))
+ (goto-char pos)
+ xmltok-type)))
+
+(defun nxml-heading-start-position ()
+ "Return the position of the start of the content of a heading element.
+Adjust the position to be after initial leading whitespace.
+Return nil if no heading element is found. Requires point to be
+immediately after the section's start-tag."
+ (let ((depth 0)
+ (heading-regexp (concat "\\`\\("
+ nxml-heading-element-name-regexp
+ "\\)\\'"))
+
+ (section-regexp (concat "\\`\\("
+ nxml-section-element-name-regexp
+ "\\)\\'"))
+ (start (point))
+ found)
+ (save-excursion
+ (while (and (xmltok-forward)
+ (cond ((memq xmltok-type '(end-tag partial-end-tag))
+ (and (not (string-match section-regexp
+ (xmltok-end-tag-local-name)))
+ (> depth 0)
+ (setq depth (1- depth))))
+ ;; XXX Not sure whether this is a good idea
+ ;;((eq xmltok-type 'empty-element)
+ ;; nil)
+ ((not (memq xmltok-type
+ '(start-tag partial-start-tag)))
+ t)
+ ((string-match section-regexp
+ (xmltok-start-tag-local-name))
+ nil)
+ ((string-match heading-regexp
+ (xmltok-start-tag-local-name))
+ (skip-chars-forward " \t\r\n")
+ (setq found (point))
+ nil)
+ (t
+ (setq depth (1+ depth))
+ t))
+ (<= (- (point) start) nxml-heading-scan-distance))))
+ found))
+
+;;; Error handling
+
+(defun nxml-report-outline-error (msg err)
+ (error msg (apply 'format (cdr err))))
+
+(defun nxml-outline-error (&rest args)
+ (signal 'nxml-outline-error args))
+
+(put 'nxml-outline-error
+ 'error-conditions
+ '(error nxml-error nxml-outline-error))
+
+(put 'nxml-outline-error
+ 'error-message
+ "Cannot create outline of buffer that is not well-formed")
+
+;;; Debugging
+
+(defun nxml-debug-overlays ()
+ (interactive)
+ (let ((overlays (nreverse (overlays-in (point-min) (point-max))))
+ overlay)
+ (while overlays
+ (setq overlay (car overlays))
+ (setq overlays (cdr overlays))
+ (when (overlay-get overlay 'nxml-outline-display)
+ (message "overlay %s: %s...%s (%s)"
+ (overlay-get overlay 'category)
+ (overlay-start overlay)
+ (overlay-end overlay)
+ (overlay-get overlay 'display))))))
+
+(provide 'nxml-outln)
+
+;;; nxml-outln.el ends here
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] Changes to lisp/nxml/nxml-outln.el,
Mark A. Hershberger <=