(rng-nxml-mode-init): Don't overwrite mode-line-process.
[bpt/emacs.git] / lisp / nxml / rng-nxml.el
1 ;;; rng-nxml.el --- make nxml-mode take advantage of rng-validate-mode
2
3 ;; Copyright (C) 2003, 2007, 2008 Free Software Foundation, Inc.
4
5 ;; Author: James Clark
6 ;; Keywords: XML, RelaxNG
7
8 ;; This file is part of GNU Emacs.
9
10 ;; GNU Emacs is free software; you can redistribute it and/or modify
11 ;; it under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 3, or (at your option)
13 ;; any later version.
14
15 ;; GNU Emacs is distributed in the hope that it will be useful,
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18 ;; GNU General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the
22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
23 ;; Boston, MA 02110-1301, USA.
24
25 ;;; Commentary:
26
27 ;;; Code:
28
29 (require 'easymenu)
30 (require 'xmltok)
31 (require 'nxml-util)
32 (require 'nxml-ns)
33 (require 'rng-match)
34 (require 'rng-util)
35 (require 'rng-valid)
36 (require 'nxml-mode)
37 (require 'rng-loc)
38
39 (defcustom rng-nxml-auto-validate-flag t
40 "*Non-nil means automatically turn on validation with nxml-mode."
41 :type 'boolean
42 :group 'relax-ng)
43
44 (defcustom rng-preferred-prefix-alist
45 '(("http://www.w3.org/1999/XSL/Transform" . "xsl")
46 ("http://www.w3.org/1999/02/22-rdf-syntax-ns#" . "rdf")
47 ("http://www.w3.org/1999/xlink" . "xlink")
48 ("http://www.w3.org/2001/XmlSchema" . "xsd")
49 ("http://www.w3.org/2001/XMLSchema-instance" . "xsi"))
50 "*Alist of namespaces vs preferred prefixes."
51 :type '(repeat (cons :tag "With"
52 (string :tag "this namespace URI")
53 (string :tag "use this prefix")))
54 :group 'relax-ng)
55
56 (defvar rng-complete-end-tags-after-< t
57 "*Non-nil means immediately after < complete on end-tag names.
58 Complete on start-tag names regardless.")
59
60 (defvar rng-nxml-easy-menu
61 '("XML"
62 ["Show Outline Only" nxml-hide-all-text-content]
63 ["Show Everything" nxml-show-all]
64 "---"
65 ["Validation" rng-validate-mode
66 :style toggle
67 :selected rng-validate-mode]
68 "---"
69 ("Set Schema"
70 ["Automatically" rng-auto-set-schema]
71 ("For Document Type"
72 :filter (lambda (menu)
73 (mapcar (lambda (type-id)
74 (vector type-id
75 (list 'rng-set-document-type
76 type-id)))
77 (rng-possible-type-ids))))
78 ["Any Well-Formed XML" rng-set-vacuous-schema]
79 ["File..." rng-set-schema-file])
80 ["Show Schema Location" rng-what-schema]
81 ["Save Schema Location" rng-save-schema-location :help
82 "Save the location of the schema currently being used for this buffer"]
83 "---"
84 ["First Error" rng-first-error :active rng-validate-mode]
85 ["Next Error" rng-next-error :active rng-validate-mode]
86 "---"
87 ["Customize nXML" (customize-group 'nxml)]))
88
89 ;;;###autoload
90 (defun rng-nxml-mode-init ()
91 "Initialize `nxml-mode' to take advantage of `rng-validate-mode'.
92 This is typically called from `nxml-mode-hook'.
93 Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil."
94 (interactive)
95 (define-key nxml-mode-map "\C-c\C-v" 'rng-validate-mode)
96 (define-key nxml-mode-map "\C-c\C-s\C-w" 'rng-what-schema)
97 (define-key nxml-mode-map "\C-c\C-s\C-a" 'rng-auto-set-schema-and-validate)
98 (define-key nxml-mode-map "\C-c\C-s\C-f" 'rng-set-schema-file-and-validate)
99 (define-key nxml-mode-map "\C-c\C-s\C-l" 'rng-save-schema-location)
100 (define-key nxml-mode-map "\C-c\C-s\C-t" 'rng-set-document-type-and-validate)
101 (define-key nxml-mode-map "\C-c\C-n" 'rng-next-error)
102 (easy-menu-define rng-nxml-menu nxml-mode-map
103 "Menu for nxml-mode used with rng-validate-mode."
104 rng-nxml-easy-menu)
105 (add-to-list 'mode-line-process
106 '(rng-validate-mode (:eval (rng-compute-mode-line-string))))
107 (cond (rng-nxml-auto-validate-flag
108 (rng-validate-mode 1)
109 (add-hook 'nxml-completion-hook 'rng-complete nil t)
110 (add-hook 'nxml-in-mixed-content-hook 'rng-in-mixed-content-p nil t))
111 (t
112 (rng-validate-mode 0)
113 (remove-hook 'nxml-completion-hook 'rng-complete t)
114 (remove-hook 'nxml-in-mixed-content-hook 'rng-in-mixed-content-p t))))
115
116 (defvar rng-tag-history nil)
117 (defvar rng-attribute-name-history nil)
118 (defvar rng-attribute-value-history nil)
119
120 (defvar rng-complete-target-names nil)
121 (defvar rng-complete-name-attribute-flag nil)
122 (defvar rng-complete-extra-strings nil)
123
124 (defun rng-complete ()
125 "Complete the string before point using the current schema.
126 Return non-nil if in a context it understands."
127 (interactive)
128 (and rng-validate-mode
129 (let ((lt-pos (save-excursion (search-backward "<" nil t)))
130 xmltok-dtd)
131 (and lt-pos
132 (= (rng-set-state-after lt-pos) lt-pos)
133 (or (rng-complete-tag lt-pos)
134 (rng-complete-end-tag lt-pos)
135 (rng-complete-attribute-name lt-pos)
136 (rng-complete-attribute-value lt-pos))))))
137
138 (defconst rng-in-start-tag-name-regex
139 (replace-regexp-in-string
140 "w"
141 xmltok-ncname-regexp
142 "<\\(?:w\\(?::w?\\)?\\)?\\="
143 t
144 t))
145
146 (defun rng-complete-tag (lt-pos)
147 (let (rng-complete-extra-strings)
148 (when (and (= lt-pos (1- (point)))
149 rng-complete-end-tags-after-<
150 rng-open-elements
151 (not (eq (car rng-open-elements) t))
152 (or rng-collecting-text
153 (rng-match-save
154 (rng-match-end-tag))))
155 (setq rng-complete-extra-strings
156 (cons (concat "/"
157 (if (caar rng-open-elements)
158 (concat (caar rng-open-elements)
159 ":"
160 (cdar rng-open-elements))
161 (cdar rng-open-elements)))
162 rng-complete-extra-strings)))
163 (when (save-excursion
164 (re-search-backward rng-in-start-tag-name-regex
165 lt-pos
166 t))
167 (and rng-collecting-text (rng-flush-text))
168 (let ((completion
169 (let ((rng-complete-target-names
170 (rng-match-possible-start-tag-names))
171 (rng-complete-name-attribute-flag nil))
172 (rng-complete-before-point (1+ lt-pos)
173 'rng-complete-qname-function
174 "Tag: "
175 nil
176 'rng-tag-history)))
177 name)
178 (when completion
179 (cond ((rng-qname-p completion)
180 (setq name (rng-expand-qname completion
181 t
182 'rng-start-tag-expand-recover))
183 (when (and name
184 (rng-match-start-tag-open name)
185 (or (not (rng-match-start-tag-close))
186 ;; need a namespace decl on the root element
187 (and (car name)
188 (not rng-open-elements))))
189 ;; attributes are required
190 (insert " ")))
191 ((member completion rng-complete-extra-strings)
192 (insert ">")))))
193 t)))
194
195 (defconst rng-in-end-tag-name-regex
196 (replace-regexp-in-string
197 "w"
198 xmltok-ncname-regexp
199 "</\\(?:w\\(?::w?\\)?\\)?\\="
200 t
201 t))
202
203 (defun rng-complete-end-tag (lt-pos)
204 (when (save-excursion
205 (re-search-backward rng-in-end-tag-name-regex
206 lt-pos
207 t))
208 (cond ((or (not rng-open-elements)
209 (eq (car rng-open-elements) t))
210 (message "No matching start-tag")
211 (ding))
212 (t
213 (let ((start-tag-name
214 (if (caar rng-open-elements)
215 (concat (caar rng-open-elements)
216 ":"
217 (cdar rng-open-elements))
218 (cdar rng-open-elements)))
219 (end-tag-name
220 (buffer-substring-no-properties (+ (match-beginning 0) 2)
221 (point))))
222 (cond ((or (> (length end-tag-name)
223 (length start-tag-name))
224 (not (string= (substring start-tag-name
225 0
226 (length end-tag-name))
227 end-tag-name)))
228 (message "Expected end-tag %s"
229 (rng-quote-string
230 (concat "</" start-tag-name ">")))
231 (ding))
232 (t
233 (delete-region (- (point) (length end-tag-name))
234 (point))
235 (insert start-tag-name ">")
236 (when (not (or rng-collecting-text
237 (rng-match-end-tag)))
238 (message "Element %s is incomplete"
239 (rng-quote-string start-tag-name))))))))
240 t))
241
242 (defconst rng-in-attribute-regex
243 (replace-regexp-in-string
244 "w"
245 xmltok-ncname-regexp
246 "<w\\(?::w\\)?\
247 \\(?:[ \t\r\n]+w\\(?::w\\)?[ \t\r\n]*=\
248 [ \t\r\n]*\\(?:\"[^\"]*\"\\|'[^']*'\\)\\)*\
249 [ \t\r\n]+\\(\\(?:w\\(?::w?\\)?\\)?\\)\\="
250 t
251 t))
252
253 (defvar rng-undeclared-prefixes nil)
254
255 (defun rng-complete-attribute-name (lt-pos)
256 (when (save-excursion
257 (re-search-backward rng-in-attribute-regex lt-pos t))
258 (let ((attribute-start (match-beginning 1))
259 rng-undeclared-prefixes)
260 (and (rng-adjust-state-for-attribute lt-pos
261 attribute-start)
262 (let ((rng-complete-target-names
263 (rng-match-possible-attribute-names))
264 (rng-complete-extra-strings
265 (mapcar (lambda (prefix)
266 (if prefix
267 (concat "xmlns:" prefix)
268 "xmlns"))
269 rng-undeclared-prefixes))
270 (rng-complete-name-attribute-flag t))
271 (rng-complete-before-point attribute-start
272 'rng-complete-qname-function
273 "Attribute: "
274 nil
275 'rng-attribute-name-history))
276 (insert "=\"")))
277 t))
278
279 (defconst rng-in-attribute-value-regex
280 (replace-regexp-in-string
281 "w"
282 xmltok-ncname-regexp
283 "<w\\(?::w\\)?\
284 \\(?:[ \t\r\n]+w\\(?::w\\)?[ \t\r\n]*=\
285 [ \t\r\n]*\\(?:\"[^\"]*\"\\|'[^']*'\\)\\)*\
286 [ \t\r\n]+\\(w\\(:w\\)?\\)[ \t\r\n]*=[ \t\r\n]*\
287 \\(\"[^\"]*\\|'[^']*\\)\\="
288 t
289 t))
290
291 (defun rng-complete-attribute-value (lt-pos)
292 (when (save-excursion
293 (re-search-backward rng-in-attribute-value-regex lt-pos t))
294 (let ((name-start (match-beginning 1))
295 (name-end (match-end 1))
296 (colon (match-beginning 2))
297 (value-start (1+ (match-beginning 3))))
298 (and (rng-adjust-state-for-attribute lt-pos
299 name-start)
300 (if (string= (buffer-substring-no-properties name-start
301 (or colon name-end))
302 "xmlns")
303 (rng-complete-before-point
304 value-start
305 (rng-strings-to-completion-alist
306 (rng-possible-namespace-uris
307 (and colon
308 (buffer-substring-no-properties (1+ colon) name-end))))
309 "Namespace URI: "
310 nil
311 'rng-namespace-uri-history)
312 (rng-adjust-state-for-attribute-value name-start
313 colon
314 name-end)
315 (rng-complete-before-point
316 value-start
317 (rng-strings-to-completion-alist
318 (rng-match-possible-value-strings))
319 "Value: "
320 nil
321 'rng-attribute-value-history))
322 (insert (char-before value-start))))
323 t))
324
325 (defun rng-possible-namespace-uris (prefix)
326 (let ((ns (if prefix (nxml-ns-get-prefix prefix)
327 (nxml-ns-get-default))))
328 (if (and ns (memq prefix (nxml-ns-changed-prefixes)))
329 (list (nxml-namespace-name ns))
330 (mapcar 'nxml-namespace-name
331 (delq nxml-xml-namespace-uri
332 (rng-match-possible-namespace-uris))))))
333
334 (defconst rng-qname-regexp
335 (concat "\\`"
336 xmltok-ncname-regexp
337 "\\(?:" ":" xmltok-ncname-regexp "\\)" "?" "\\'"))
338
339 (defun rng-qname-p (string)
340 (and (string-match rng-qname-regexp string) t))
341
342 (defun rng-expand-qname (qname &optional defaultp recover-fun)
343 (setq qname (rng-split-qname qname))
344 (let ((prefix (car qname)))
345 (if prefix
346 (let ((ns (nxml-ns-get-prefix qname)))
347 (cond (ns (cons ns (cdr qname)))
348 (recover-fun (funcall recover-fun prefix (cdr qname)))))
349 (cons (and defaultp (nxml-ns-get-default)) (cdr qname)))))
350
351 (defun rng-start-tag-expand-recover (prefix local-name)
352 (let ((ns (rng-match-infer-start-tag-namespace local-name)))
353 (and ns
354 (cons ns local-name))))
355
356 (defun rng-split-qname (qname)
357 (if (string-match ":" qname)
358 (cons (substring qname 0 (match-beginning 0))
359 (substring qname (match-end 0)))
360 (cons nil qname)))
361
362 (defun rng-in-mixed-content-p ()
363 "Return non-nil if point is in mixed content.
364 Return nil only if point is definitely not in mixed content.
365 If unsure, return non-nil."
366 (if (eq rng-current-schema rng-any-element)
367 t
368 (rng-set-state-after)
369 (rng-match-mixed-text)))
370
371 (defun rng-set-state-after (&optional pos)
372 "Set the state for after parsing the first token with endpoint >= POS.
373 This does not change the xmltok state or point. However, it does
374 set `xmltok-dtd'. Returns the position of the end of the token."
375 (unless pos (setq pos (point)))
376 (when (< rng-validate-up-to-date-end pos)
377 (message "Parsing...")
378 (while (and (rng-do-some-validation)
379 (< rng-validate-up-to-date-end pos))
380 ;; Display percentage validated.
381 (force-mode-line-update)
382 ;; Force redisplay but don't allow idle timers to run.
383 (let ((timer-idle-list nil))
384 (sit-for 0)))
385 (message "Parsing...done"))
386 (save-excursion
387 (save-restriction
388 (widen)
389 (nxml-with-invisible-motion
390 (if (= pos 1)
391 (rng-set-initial-state)
392 (let ((state (get-text-property (1- pos) 'rng-state)))
393 (cond (state
394 (rng-restore-state state)
395 (goto-char pos))
396 (t
397 (let ((start (previous-single-property-change pos
398 'rng-state)))
399 (cond (start
400 (rng-restore-state (get-text-property (1- start)
401 'rng-state))
402 (goto-char start))
403 (t (rng-set-initial-state))))))))
404 (xmltok-save
405 (if (= (point) 1)
406 (xmltok-forward-prolog)
407 (setq xmltok-dtd rng-dtd))
408 (cond ((and (< pos (point))
409 ;; This handles the case where the prolog ends
410 ;; with a < without any following name-start
411 ;; character. This will be treated by the parser
412 ;; as part of the prolog, but we want to treat
413 ;; it as the start of the instance.
414 (eq (char-after pos) ?<)
415 (<= (point)
416 (save-excursion
417 (goto-char (1+ pos))
418 (skip-chars-forward " \t\r\n")
419 (point))))
420 pos)
421 ((< (point) pos)
422 (let ((rng-dt-namespace-context-getter
423 '(nxml-ns-get-context))
424 (rng-parsing-for-state t))
425 (rng-forward pos))
426 (point))
427 (t pos)))))))
428
429 (defun rng-adjust-state-for-attribute (lt-pos start)
430 (xmltok-save
431 (save-excursion
432 (goto-char lt-pos)
433 (when (memq (xmltok-forward)
434 '(start-tag
435 partial-start-tag
436 empty-element
437 partial-empty-element))
438 (when (< start (point))
439 (setq xmltok-namespace-attributes
440 (rng-prune-attribute-at start
441 xmltok-namespace-attributes))
442 (setq xmltok-attributes
443 (rng-prune-attribute-at start
444 xmltok-attributes)))
445 (let ((rng-parsing-for-state t)
446 (rng-dt-namespace-context-getter '(nxml-ns-get-context)))
447 (rng-process-start-tag 'stop)
448 (rng-find-undeclared-prefixes)
449 t)))))
450
451 (defun rng-find-undeclared-prefixes ()
452 ;; Start with the newly effective namespace declarations.
453 ;; (Includes declarations added during recovery.)
454 (setq rng-undeclared-prefixes (nxml-ns-changed-prefixes))
455 (let ((iter xmltok-attributes)
456 (ns-state (nxml-ns-state))
457 att)
458 ;; Add namespace prefixes used in this tag,
459 ;; but not declared in the parent.
460 (nxml-ns-pop-state)
461 (while iter
462 (setq att (car iter))
463 (let ((prefix (xmltok-attribute-prefix att)))
464 (when (and prefix
465 (not (member prefix rng-undeclared-prefixes))
466 (not (nxml-ns-get-prefix prefix)))
467 (setq rng-undeclared-prefixes
468 (cons prefix rng-undeclared-prefixes))))
469 (setq iter (cdr iter)))
470 (nxml-ns-set-state ns-state)
471 ;; Remove namespace prefixes explicitly declared.
472 (setq iter xmltok-namespace-attributes)
473 (while iter
474 (setq att (car iter))
475 (setq rng-undeclared-prefixes
476 (delete (and (xmltok-attribute-prefix att)
477 (xmltok-attribute-local-name att))
478 rng-undeclared-prefixes))
479 (setq iter (cdr iter)))))
480
481 (defun rng-prune-attribute-at (start atts)
482 (when atts
483 (let ((cur atts))
484 (while (if (eq (xmltok-attribute-name-start (car cur)) start)
485 (progn
486 (setq atts (delq (car cur) atts))
487 nil)
488 (setq cur (cdr cur)))))
489 atts))
490
491 (defun rng-adjust-state-for-attribute-value (name-start
492 colon
493 name-end)
494 (let* ((prefix (if colon
495 (buffer-substring-no-properties name-start colon)
496 nil))
497 (local-name (buffer-substring-no-properties (if colon
498 (1+ colon)
499 name-start)
500 name-end))
501 (ns (and prefix (nxml-ns-get-prefix prefix))))
502 (and (or (not prefix) ns)
503 (rng-match-attribute-name (cons ns local-name)))))
504
505 (defun rng-complete-qname-function (string predicate flag)
506 (let ((alist (mapcar (lambda (name) (cons name nil))
507 (rng-generate-qname-list string))))
508 (cond ((not flag)
509 (try-completion string alist predicate))
510 ((eq flag t)
511 (all-completions string alist predicate))
512 ((eq flag 'lambda)
513 (and (assoc string alist) t)))))
514
515 (defun rng-generate-qname-list (&optional string)
516 (let ((forced-prefix (and string
517 (string-match ":" string)
518 (> (match-beginning 0) 0)
519 (substring string
520 0
521 (match-beginning 0))))
522 (namespaces (mapcar 'car rng-complete-target-names))
523 ns-prefixes-alist ns-prefixes iter ns prefer)
524 (while namespaces
525 (setq ns (car namespaces))
526 (when ns
527 (setq ns-prefixes-alist
528 (cons (cons ns (nxml-ns-prefixes-for
529 ns
530 rng-complete-name-attribute-flag))
531 ns-prefixes-alist)))
532 (setq namespaces (delq ns (cdr namespaces))))
533 (setq iter ns-prefixes-alist)
534 (while iter
535 (setq ns-prefixes (car iter))
536 (setq ns (car ns-prefixes))
537 (when (null (cdr ns-prefixes))
538 ;; No declared prefix for the namespace
539 (if forced-prefix
540 ;; If namespace non-nil and prefix undeclared,
541 ;; use forced prefix.
542 (when (and ns
543 (not (nxml-ns-get-prefix forced-prefix)))
544 (setcdr ns-prefixes (list forced-prefix)))
545 (setq prefer (rng-get-preferred-unused-prefix ns))
546 (when prefer
547 (setcdr ns-prefixes (list prefer)))
548 ;; Unless it's an attribute with a non-nil namespace,
549 ;; allow no prefix for this namespace.
550 (unless rng-complete-name-attribute-flag
551 (setcdr ns-prefixes (cons nil (cdr ns-prefixes))))))
552 (setq iter (cdr iter)))
553 (rng-uniquify-equal
554 (sort (apply 'append
555 (cons rng-complete-extra-strings
556 (mapcar (lambda (name)
557 (if (car name)
558 (mapcar (lambda (prefix)
559 (if prefix
560 (concat prefix
561 ":"
562 (cdr name))
563 (cdr name)))
564 (cdr (assoc (car name)
565 ns-prefixes-alist)))
566 (list (cdr name))))
567 rng-complete-target-names)))
568 'string<))))
569
570 (defun rng-get-preferred-unused-prefix (ns)
571 (let ((ns-prefix (assoc (symbol-name ns) rng-preferred-prefix-alist))
572 iter prefix)
573 (when ns-prefix
574 (setq prefix (cdr ns-prefix))
575 (when (nxml-ns-get-prefix prefix)
576 ;; try to find an unused prefix
577 (setq iter (memq ns-prefix rng-preferred-prefix-alist))
578 (while (and iter
579 (setq ns-prefix (assoc ns iter)))
580 (if (nxml-ns-get-prefix (cdr ns-prefix))
581 (setq iter (memq ns-prefix iter))
582 (setq prefix (cdr ns-prefix))
583 nil))))
584 prefix))
585
586 (defun rng-strings-to-completion-alist (strings)
587 (mapcar (lambda (s) (cons s s))
588 (rng-uniquify-equal (sort (mapcar 'rng-escape-string strings)
589 'string<))))
590
591 (provide 'rng-nxml)
592
593 ;; arch-tag: bec0d6ed-6be1-4540-9c2c-6f56e8e55d8b
594 ;;; rng-nxml.el ends here