lisp/nxml/rng-nxml.el

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