[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Emacs-diffs] master d7896a6: * lisp/nxml: Use standard completion; it a
|
From: |
Stefan Monnier |
|
Subject: |
[Emacs-diffs] master d7896a6: * lisp/nxml: Use standard completion; it also works for company-mode |
|
Date: |
Sat, 16 Jan 2016 19:03:47 +0000 |
branch: master
commit d7896a6f773dc4ae4e1b56c34b6708fe2bc5610a
Author: Stefan Monnier <address@hidden>
Commit: Stefan Monnier <address@hidden>
* lisp/nxml: Use standard completion; it also works for company-mode
* lisp/nxml/nxml-mode.el (nxml-complete): Obsolete.
(nxml-completion-at-point-function): Remove.
(nxml-mode): Don't set completion-at-point-functions.
* lisp/nxml/rng-nxml.el (rng-nxml-mode-init): Set it here instead.
(rng-completion-at-point): Rename from rng-complete and mark it
non-interactive. It is now to be used as completion-at-point-function.
(rng-complete-tag, rng-complete-end-tag, rng-complete-attribute-name)
(rng-complete-attribute-value): Don't perform completion, but return
completion data instead.
(rng-complete-qname-function, rng-generate-qname-list): Add a few
arguments, previously passed via dynamic coping.
(rng-strings-to-completion-table): Rename from
rng-strings-to-completion-alist. Don't return an alist. Don't both
sorting and uniquifying.
* lisp/nxml/rng-util.el (rng-complete-before-point): Delete function.
(rng-completion-exact-p, rng-quote-string): Delete functions.
* lisp/nxml/rng-valid.el (rng-recover-start-tag-open)
(rng-missing-attributes-message, rng-missing-element-message)
(rng-mark-missing-end-tags): Use explicit ".." in formats rather than
calling rng-quote-string everywhere.
---
lisp/nxml/nxml-mode.el | 28 +------
lisp/nxml/rng-nxml.el | 223 +++++++++++++++++++++---------------------------
lisp/nxml/rng-util.el | 63 --------------
lisp/nxml/rng-valid.el | 35 +++-----
4 files changed, 115 insertions(+), 234 deletions(-)
diff --git a/lisp/nxml/nxml-mode.el b/lisp/nxml/nxml-mode.el
index b7a4e2e..c6600b1 100644
--- a/lisp/nxml/nxml-mode.el
+++ b/lisp/nxml/nxml-mode.el
@@ -535,8 +535,6 @@ Many aspects this mode can be customized using
(nxml-clear-inside (point-min) (point-max))
(nxml-with-invisible-motion
(nxml-scan-prolog)))))
- (add-hook 'completion-at-point-functions
- #'nxml-completion-at-point-function nil t)
(setq-local syntax-propertize-function #'nxml-after-change)
(add-hook 'change-major-mode-hook #'nxml-cleanup nil t)
@@ -557,7 +555,6 @@ Many aspects this mode can be customized using
t ; keywords-only; we highlight comments and strings here
nil ; font-lock-keywords-case-fold-search. XML is case sensitive
nil ; no special syntax table
- nil ; no automatic syntactic fontification
(font-lock-extend-region-functions . (nxml-extend-region))
(jit-lock-contextually . t)
(font-lock-unfontify-region-function . nxml-unfontify-region)))
@@ -1577,30 +1574,7 @@ of the line. This expects the xmltok-* variables to be
set up as by
(t (back-to-indentation)))
(current-column))
-;;; Completion
-
-(defun nxml-complete ()
- "Perform completion on the symbol preceding point.
-
-Inserts as many characters as can be completed. However, if not even
-one character can be completed, then a buffer with the possibilities
-is popped up and the symbol is read from the minibuffer with
-completion. If the symbol is complete, then any characters that must
-follow the symbol are also inserted.
-
-The name space used for completion and what is treated as a symbol
-depends on the context. The contexts in which completion is performed
-depend on `nxml-completion-hook'."
- (interactive)
- (unless (run-hook-with-args-until-success 'nxml-completion-hook)
- ;; Eventually we will complete on entity names here.
- (ding)
- (message "Cannot complete in this context")))
-
-(defun nxml-completion-at-point-function ()
- "Call `nxml-complete' to perform completion at point."
- (when nxml-bind-meta-tab-to-complete-flag
- #'nxml-complete))
+(define-obsolete-function-alias 'nxml-complete #'completion-at-point "26.1")
;;; Movement
diff --git a/lisp/nxml/rng-nxml.el b/lisp/nxml/rng-nxml.el
index 467f7af..954a1eb 100644
--- a/lisp/nxml/rng-nxml.el
+++ b/lisp/nxml/rng-nxml.el
@@ -111,25 +111,15 @@ Validation will be enabled if
`rng-nxml-auto-validate-flag' is non-nil."
'append)
(cond (rng-nxml-auto-validate-flag
(rng-validate-mode 1)
- (add-hook 'nxml-completion-hook #'rng-complete nil t)
+ (add-hook 'completion-at-point-functions #'rng-completion-at-point nil
t)
(add-hook 'nxml-in-mixed-content-hook #'rng-in-mixed-content-p nil t))
(t
(rng-validate-mode 0)
- (remove-hook 'nxml-completion-hook #'rng-complete t)
+ (remove-hook 'completion-at-point-functions #'rng-completion-at-point
t)
(remove-hook 'nxml-in-mixed-content-hook #'rng-in-mixed-content-p t))))
-(defvar rng-tag-history nil)
-(defvar rng-attribute-name-history nil)
-(defvar rng-attribute-value-history nil)
-
-(defvar rng-complete-target-names nil)
-(defvar rng-complete-name-attribute-flag nil)
-(defvar rng-complete-extra-strings nil)
-
-(defun rng-complete ()
- "Complete the string before point using the current schema.
-Return non-nil if in a context it understands."
- (interactive)
+(defun rng-completion-at-point ()
+ "Return completion data for the string before point using the current
schema."
(and rng-validate-mode
(let ((lt-pos (save-excursion (search-backward "<" nil t)))
xmltok-dtd)
@@ -149,53 +139,48 @@ Return non-nil if in a context it understands."
t))
(defun rng-complete-tag (lt-pos)
- (let (rng-complete-extra-strings)
- (when (and (= lt-pos (1- (point)))
- rng-complete-end-tags-after-<
- rng-open-elements
- (not (eq (car rng-open-elements) t))
- (or rng-collecting-text
- (rng-match-save
- (rng-match-end-tag))))
- (setq rng-complete-extra-strings
- (cons (concat "/"
- (if (caar rng-open-elements)
- (concat (caar rng-open-elements)
- ":"
- (cdar rng-open-elements))
- (cdar rng-open-elements)))
- rng-complete-extra-strings)))
+ (let ((extra-strings
+ (when (and (= lt-pos (1- (point)))
+ rng-complete-end-tags-after-<
+ rng-open-elements
+ (not (eq (car rng-open-elements) t))
+ (or rng-collecting-text
+ (rng-match-save
+ (rng-match-end-tag))))
+ (list (concat "/"
+ (if (caar rng-open-elements)
+ (concat (caar rng-open-elements)
+ ":"
+ (cdar rng-open-elements))
+ (cdar rng-open-elements)))))))
(when (save-excursion
(re-search-backward rng-in-start-tag-name-regex
lt-pos
t))
(and rng-collecting-text (rng-flush-text))
- (let ((completion
- (let ((rng-complete-target-names
- (rng-match-possible-start-tag-names))
- (rng-complete-name-attribute-flag nil))
- (rng-complete-before-point (1+ lt-pos)
- 'rng-complete-qname-function
- "Tag: "
- nil
- 'rng-tag-history)))
- name)
- (when completion
- (cond ((rng-qname-p completion)
- (setq name (rng-expand-qname completion
- t
- 'rng-start-tag-expand-recover))
- (when (and name
- (rng-match-start-tag-open name)
- (or (not (rng-match-start-tag-close))
- ;; need a namespace decl on the root element
- (and (car name)
- (not rng-open-elements))))
- ;; attributes are required
- (insert " ")))
- ((member completion rng-complete-extra-strings)
- (insert ">")))))
- t)))
+ (let ((target-names (rng-match-possible-start-tag-names)))
+ `(,(1+ lt-pos)
+ ,(save-excursion (skip-chars-forward "[[:alnum:]_.-:]") (point))
+ ,(apply-partially #'rng-complete-qname-function
+ target-names nil extra-strings)
+ :exit-function
+ ,(lambda (completion status)
+ (cond
+ ((not (eq status 'finished)) nil)
+ ((rng-qname-p completion)
+ (let ((name (rng-expand-qname completion
+ t
+ #'rng-start-tag-expand-recover)))
+ (when (and name
+ (rng-match-start-tag-open name)
+ (or (not (rng-match-start-tag-close))
+ ;; need a namespace decl on the root element
+ (and (car name)
+ (not rng-open-elements))))
+ ;; attributes are required
+ (insert " "))))
+ ((member completion extra-strings)
+ (insert ">")))))))))
(defconst rng-in-end-tag-name-regex
(replace-regexp-in-string
@@ -220,29 +205,18 @@ Return non-nil if in a context it understands."
(concat (caar rng-open-elements)
":"
(cdar rng-open-elements))
- (cdar rng-open-elements)))
- (end-tag-name
- (buffer-substring-no-properties (+ (match-beginning 0) 2)
- (point))))
- (cond ((or (> (length end-tag-name)
- (length start-tag-name))
- (not (string= (substring start-tag-name
- 0
- (length end-tag-name))
- end-tag-name)))
- (message "Expected end-tag %s"
- (rng-quote-string
- (concat "</" start-tag-name ">")))
- (ding))
- (t
- (delete-region (- (point) (length end-tag-name))
- (point))
- (insert start-tag-name ">")
- (when (not (or rng-collecting-text
- (rng-match-end-tag)))
- (message "Element %s is incomplete"
- (rng-quote-string start-tag-name))))))))
- t))
+ (cdar rng-open-elements))))
+ `(,(+ (match-beginning 0) 2)
+ ,(save-excursion (skip-chars-forward "[[:alnum:]_.-:]") (point))
+ ,(list start-tag-name) ;Sole completion candidate.
+ :exit-function
+ ,(lambda (_completion status)
+ (when (eq status 'finished)
+ (unless (eq (char-after) ?>) (insert ">"))
+ (when (not (or rng-collecting-text
+ (rng-match-end-tag)))
+ (message "Element \"%s\" is incomplete"
+ start-tag-name))))))))))
(defconst rng-in-attribute-regex
(replace-regexp-in-string
@@ -264,22 +238,24 @@ Return non-nil if in a context it understands."
rng-undeclared-prefixes)
(and (rng-adjust-state-for-attribute lt-pos
attribute-start)
- (let ((rng-complete-target-names
+ (let ((target-names
(rng-match-possible-attribute-names))
- (rng-complete-extra-strings
+ (extra-strings
(mapcar (lambda (prefix)
(if prefix
(concat "xmlns:" prefix)
"xmlns"))
- rng-undeclared-prefixes))
- (rng-complete-name-attribute-flag t))
- (rng-complete-before-point attribute-start
- 'rng-complete-qname-function
- "Attribute: "
- nil
- 'rng-attribute-name-history))
- (insert "=\"")))
- t))
+ rng-undeclared-prefixes)))
+ `(,attribute-start
+ ,(save-excursion (skip-chars-forward "[[:alnum:]_.-:]") (point))
+ ,(apply-partially #'rng-complete-qname-function
+ target-names t extra-strings)
+ :exit-function
+ ,(lambda (_completion status)
+ (when (and (eq status 'finished)
+ (not (looking-at "=")))
+ (insert "=\"\"")
+ (forward-char -1)))))))))
(defconst rng-in-attribute-value-regex
(replace-regexp-in-string
@@ -296,36 +272,33 @@ Return non-nil if in a context it understands."
(defun rng-complete-attribute-value (lt-pos)
(when (save-excursion
(re-search-backward rng-in-attribute-value-regex lt-pos t))
- (let ((name-start (match-beginning 1))
- (name-end (match-end 1))
- (colon (match-beginning 2))
- (value-start (1+ (match-beginning 3))))
+ (let* ((name-start (match-beginning 1))
+ (name-end (match-end 1))
+ (colon (match-beginning 2))
+ (value-start (1+ (match-beginning 3)))
+ (exit-function
+ (lambda (_completion status)
+ (when (eq status 'finished)
+ (let ((delim (char-before value-start)))
+ (unless (eq (char-after) delim) (insert delim)))))))
(and (rng-adjust-state-for-attribute lt-pos
name-start)
(if (string= (buffer-substring-no-properties name-start
(or colon name-end))
"xmlns")
- (rng-complete-before-point
- value-start
- (rng-strings-to-completion-alist
- (rng-possible-namespace-uris
- (and colon
- (buffer-substring-no-properties (1+ colon) name-end))))
- "Namespace URI: "
- nil
- 'rng-namespace-uri-history)
+ `(,value-start ,(point)
+ ,(rng-strings-to-completion-table
+ (rng-possible-namespace-uris
+ (and colon
+ (buffer-substring-no-properties (1+ colon)
name-end))))
+ :exit-function ,exit-function)
(rng-adjust-state-for-attribute-value name-start
colon
name-end)
- (rng-complete-before-point
- value-start
- (rng-strings-to-completion-alist
- (rng-match-possible-value-strings))
- "Value: "
- nil
- 'rng-attribute-value-history))
- (insert (char-before value-start))))
- t))
+ `(,value-start ,(point)
+ ,(rng-strings-to-completion-table
+ (rng-match-possible-value-strings))
+ :exit-function ,exit-function))))))
(defun rng-possible-namespace-uris (prefix)
(let ((ns (if prefix (nxml-ns-get-prefix prefix)
@@ -505,17 +478,21 @@ set `xmltok-dtd'. Returns the position of the end of the
token."
(and (or (not prefix) ns)
(rng-match-attribute-name (cons ns local-name)))))
-(defun rng-complete-qname-function (string predicate flag)
- (complete-with-action flag (rng-generate-qname-list string) string
predicate))
+(defun rng-complete-qname-function (candidates attributes-flag extra-strings
+ string predicate flag)
+ (complete-with-action flag
+ (rng-generate-qname-list
+ string candidates attributes-flag extra-strings)
+ string predicate))
-(defun rng-generate-qname-list (&optional string)
+(defun rng-generate-qname-list (&optional string candidates attribute-flag
extra-strings)
(let ((forced-prefix (and string
(string-match ":" string)
(> (match-beginning 0) 0)
(substring string
0
(match-beginning 0))))
- (namespaces (mapcar 'car rng-complete-target-names))
+ (namespaces (mapcar #'car candidates))
ns-prefixes-alist ns-prefixes iter ns prefer)
(while namespaces
(setq ns (car namespaces))
@@ -523,7 +500,7 @@ set `xmltok-dtd'. Returns the position of the end of the
token."
(setq ns-prefixes-alist
(cons (cons ns (nxml-ns-prefixes-for
ns
- rng-complete-name-attribute-flag))
+ attribute-flag))
ns-prefixes-alist)))
(setq namespaces (delq ns (cdr namespaces))))
(setq iter ns-prefixes-alist)
@@ -543,12 +520,12 @@ set `xmltok-dtd'. Returns the position of the end of the
token."
(setcdr ns-prefixes (list prefer)))
;; Unless it's an attribute with a non-nil namespace,
;; allow no prefix for this namespace.
- (unless rng-complete-name-attribute-flag
+ (unless attribute-flag
(setcdr ns-prefixes (cons nil (cdr ns-prefixes))))))
(setq iter (cdr iter)))
(rng-uniquify-equal
(sort (apply #'append
- (cons rng-complete-extra-strings
+ (cons extra-strings
(mapcar (lambda (name)
(if (car name)
(mapcar (lambda (prefix)
@@ -560,7 +537,7 @@ set `xmltok-dtd'. Returns the position of the end of the
token."
(cdr (assoc (car name)
ns-prefixes-alist)))
(list (cdr name))))
- rng-complete-target-names)))
+ candidates)))
'string<))))
(defun rng-get-preferred-unused-prefix (ns)
@@ -579,10 +556,8 @@ set `xmltok-dtd'. Returns the position of the end of the
token."
nil))))
prefix))
-(defun rng-strings-to-completion-alist (strings)
- (mapcar (lambda (s) (cons s s))
- (rng-uniquify-equal (sort (mapcar #'rng-escape-string strings)
- 'string<))))
+(defun rng-strings-to-completion-table (strings)
+ (mapcar #'rng-escape-string strings))
(provide 'rng-nxml)
diff --git a/lisp/nxml/rng-util.el b/lisp/nxml/rng-util.el
index 4c14e2b..c5d4b65 100644
--- a/lisp/nxml/rng-util.el
+++ b/lisp/nxml/rng-util.el
@@ -82,69 +82,6 @@ LIST is not modified."
(cons item nil))))))))
list)))
-(defun rng-complete-before-point (start table prompt &optional predicate hist)
- "Complete text between START and point.
-Replaces the text between START and point with a string chosen using a
-completion table and, when needed, input read from the user with the
-minibuffer.
-Returns the new string if either a complete and unique completion was
-determined automatically or input was read from the user. Otherwise,
-returns nil.
-TABLE is an alist, a symbol bound to a function or an obarray as with
-the function `completing-read'.
-PROMPT is the string to prompt with if user input is needed.
-PREDICATE is nil or a function as with `completing-read'.
-HIST, if non-nil, specifies a history list as with `completing-read'."
- (let* ((orig (buffer-substring-no-properties start (point)))
- (completion (try-completion orig table predicate)))
- (cond ((not completion)
- (if (string= orig "")
- (message "No completions available")
- (message "No completion for %s" (rng-quote-string orig)))
- (ding)
- nil)
- ((eq completion t) orig)
- ((not (string= completion orig))
- (delete-region start (point))
- (insert completion)
- (cond ((not (rng-completion-exact-p completion table predicate))
- (message "Incomplete")
- nil)
- ((eq (try-completion completion table predicate) t)
- completion)
- (t
- (message "Complete but not unique")
- nil)))
- (t
- (setq completion
- (let ((saved-minibuffer-setup-hook
- (default-value 'minibuffer-setup-hook)))
- (add-hook 'minibuffer-setup-hook
- 'minibuffer-completion-help
- t)
- (unwind-protect
- (completing-read prompt
- table
- predicate
- nil
- orig
- hist)
- (setq-default minibuffer-setup-hook
- saved-minibuffer-setup-hook))))
- (delete-region start (point))
- (insert completion)
- completion))))
-
-(defun rng-completion-exact-p (string table predicate)
- (cond ((symbolp table)
- (funcall table string predicate 'lambda))
- ((vectorp table)
- (intern-soft string table))
- (t (assoc string table))))
-
-(defun rng-quote-string (s)
- (concat "\"" s "\""))
-
(defun rng-escape-string (s)
(replace-regexp-in-string "[&\"<>]"
(lambda (match)
diff --git a/lisp/nxml/rng-valid.el b/lisp/nxml/rng-valid.el
index 9b0b4df..946bf79 100644
--- a/lisp/nxml/rng-valid.el
+++ b/lisp/nxml/rng-valid.el
@@ -1138,9 +1138,8 @@ as empty-element."
(rng-match-start-tag-open required)
(rng-match-after)
(rng-match-start-tag-open name))
- (rng-mark-invalid (concat "Missing element "
- (rng-quote-string
- (rng-name-to-string required)))
+ (rng-mark-invalid (format "Missing element \"%s\""
+ (rng-name-to-string required))
xmltok-start
(1+ xmltok-start)))
((and (rng-match-optionalize-elements)
@@ -1177,16 +1176,14 @@ as empty-element."
(cond ((not required-attributes)
"Required attributes missing")
((not (cdr required-attributes))
- (concat "Missing attribute "
- (rng-quote-string
- (rng-name-to-string (car required-attributes) t))))
+ (format "Missing attribute \"%s\""
+ (rng-name-to-string (car required-attributes) t)))
(t
- (concat "Missing attributes "
+ (format "Missing attributes \"%s\""
(mapconcat (lambda (nm)
- (rng-quote-string
- (rng-name-to-string nm t)))
+ (rng-name-to-string nm t))
required-attributes
- ", "))))))
+ "\", \""))))))
(defun rng-process-end-tag (&optional partial)
(cond ((not rng-open-elements)
@@ -1229,8 +1226,7 @@ as empty-element."
(defun rng-missing-element-message ()
(let ((element (rng-match-required-element-name)))
(if element
- (concat "Missing element "
- (rng-quote-string (rng-name-to-string element)))
+ (format "Missing element \"%s\"" (rng-name-to-string element))
"Required child elements missing")))
(defun rng-recover-mismatched-end-tag ()
@@ -1258,17 +1254,16 @@ as empty-element."
(defun rng-mark-missing-end-tags (missing)
(rng-mark-not-well-formed
- (format "Missing end-tag%s %s"
+ (format "Missing end-tag%s \"%s\""
(if (null (cdr missing)) "" "s")
(mapconcat (lambda (name)
- (rng-quote-string
- (if (car name)
- (concat (car name)
- ":"
- (cdr name))
- (cdr name))))
+ (if (car name)
+ (concat (car name)
+ ":"
+ (cdr name))
+ (cdr name)))
missing
- ", "))
+ "\", \""))
xmltok-start
(+ xmltok-start 2)))
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Emacs-diffs] master d7896a6: * lisp/nxml: Use standard completion; it also works for company-mode,
Stefan Monnier <=