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