root/dotfiles/emacs/37to/site-lisp/nxhtml/nxml-mode-20041004/nxml-outln.el @ 27526

Revision 27526, 36.1 kB (checked in by 37to, 4 years ago)

elispの追加

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