+(defun completion-table-with-quoting (table unquote requote)
+ ;; A difficult part of completion-with-quoting is to map positions in the
+ ;; quoted string to equivalent positions in the unquoted string and
+ ;; vice-versa. There is no efficient and reliable algorithm that works for
+ ;; arbitrary quote and unquote functions.
+ ;; So to map from quoted positions to unquoted positions, we simply assume
+ ;; that `concat' and `unquote' commute (which tends to be the case).
+ ;; And we ask `requote' to do the work of mapping from unquoted positions
+ ;; back to quoted positions.
+ "Return a new completion table operating on quoted text.
+TABLE operates on the unquoted text.
+UNQUOTE is a function that takes a string and returns a new unquoted string.
+REQUOTE is a function of 2 args (UPOS QSTR) where
+ QSTR is a string entered by the user (and hence indicating
+ the user's preferred form of quoting); and
+ UPOS is a position within the unquoted form of QSTR.
+REQUOTE should return a pair (QPOS . QFUN) such that QPOS is the
+position corresponding to UPOS but in QSTR, and QFUN is a function
+of one argument (a string) which returns that argument appropriately quoted
+for use at QPOS."
+ ;; FIXME: One problem with the current setup is that `qfun' doesn't know if
+ ;; its argument is "the end of the completion", so if the quoting used double
+ ;; quotes (for example), we end up completing "fo" to "foobar and throwing
+ ;; away the closing double quote.
+ (lambda (string pred action)
+ (cond
+ ((eq action 'metadata)
+ (append (completion-metadata string table pred)
+ '((completion--unquote-requote . t))))
+
+ ((eq action 'lambda) ;;test-completion
+ (let ((ustring (funcall unquote string)))
+ (test-completion ustring table pred)))
+
+ ((eq (car-safe action) 'boundaries)
+ (let* ((ustring (funcall unquote string))
+ (qsuffix (cdr action))
+ (ufull (if (zerop (length qsuffix)) ustring
+ (funcall unquote (concat string qsuffix))))
+ (_ (assert (string-prefix-p ustring ufull)))
+ (usuffix (substring ufull (length ustring)))
+ (boundaries (completion-boundaries ustring table pred usuffix))
+ (qlboundary (car (funcall requote (car boundaries) string)))
+ (qrboundary (if (zerop (cdr boundaries)) 0 ;Common case.
+ (let* ((urfullboundary
+ (+ (cdr boundaries) (length ustring))))
+ (- (car (funcall requote urfullboundary
+ (concat string qsuffix)))
+ (length string))))))
+ (list* 'boundaries qlboundary qrboundary)))
+
+ ;; In "normal" use a c-t-with-quoting completion table should never be
+ ;; called with action in (t nil) because `completion--unquote' should have
+ ;; been called before and would have returned a different completion table
+ ;; to apply to the unquoted text. But there's still a lot of code around
+ ;; that likes to use all/try-completions directly, so we do our best to
+ ;; handle those calls as well as we can.
+
+ ((eq action nil) ;;try-completion
+ (let* ((ustring (funcall unquote string))
+ (completion (try-completion ustring table pred)))
+ ;; Most forms of quoting allow several ways to quote the same string.
+ ;; So here we could simply requote `completion' in a kind of
+ ;; "canonical" quoted form without paying attention to the way
+ ;; `string' was quoted. But since we have to solve the more complex
+ ;; problems of "pay attention to the original quoting" for
+ ;; all-completions, we may as well use it here, since it provides
+ ;; a nicer behavior.
+ (if (not (stringp completion)) completion
+ (car (completion--twq-try
+ string ustring completion 0 unquote requote)))))
+
+ ((eq action t) ;;all-completions
+ ;; When all-completions is used for completion-try/all-completions
+ ;; (e.g. for `pcm' style), we can't do the job properly here because
+ ;; the caller will match our output against some pattern derived from
+ ;; the user's (quoted) input, and we don't have access to that
+ ;; pattern, so we can't know how to requote our output so that it
+ ;; matches the quoting used in the pattern. It is to fix this
+ ;; fundamental problem that we have to introduce the new
+ ;; unquote-requote method so that completion-try/all-completions can
+ ;; pass the unquoted string to the style functions.
+ (pcase-let*
+ ((ustring (funcall unquote string))
+ (completions (all-completions ustring table pred))
+ (boundary (car (completion-boundaries ustring table pred "")))
+ (completions
+ (completion--twq-all
+ string ustring completions boundary unquote requote))
+ (last (last completions)))
+ (when (consp last) (setcdr last nil))
+ completions))
+
+ ((eq action 'completion--unquote)
+ (let ((ustring (funcall unquote string))
+ (uprefix (funcall unquote (substring string 0 pred))))
+ ;; We presume (more or less) that `concat' and `unquote' commute.
+ (assert (string-prefix-p uprefix ustring))
+ (list ustring table (length uprefix)
+ (lambda (unquoted-result op)
+ (pcase op
+ (`1 ;;try
+ (if (not (stringp (car-safe unquoted-result)))
+ unquoted-result
+ (completion--twq-try
+ string ustring
+ (car unquoted-result) (cdr unquoted-result)
+ unquote requote)))
+ (`2 ;;all
+ (let* ((last (last unquoted-result))
+ (base (or (cdr last) 0)))
+ (when last
+ (setcdr last nil)
+ (completion--twq-all string ustring
+ unquoted-result base
+ unquote requote))))))))))))
+
+(defun completion--twq-try (string ustring completion point
+ unquote requote)
+ ;; Basically two case: either the new result is
+ ;; - commonprefix1 <point> morecommonprefix <qpos> suffix
+ ;; - commonprefix <qpos> newprefix <point> suffix
+ (pcase-let*
+ ((prefix (fill-common-string-prefix ustring completion))
+ (suffix (substring completion (max point (length prefix))))
+ (`(,qpos . ,qfun) (funcall requote (length prefix) string))
+ (qstr1 (if (> point (length prefix))
+ (funcall qfun (substring completion (length prefix) point))))
+ (qsuffix (funcall qfun suffix))
+ (qstring (concat (substring string 0 qpos) qstr1 qsuffix))
+ (qpoint
+ (cond
+ ((zerop point) 0)
+ ((> point (length prefix)) (+ qpos (length qstr1)))
+ (t (car (funcall requote point string))))))
+ ;; Make sure `requote' worked.
+ (assert (equal (funcall unquote qstring) completion))
+ (cons qstring qpoint)))
+
+(defun completion--string-equal-p (s1 s2)
+ (eq t (compare-strings s1 nil nil s2 nil nil 'ignore-case)))
+
+(defun completion--twq-all (string ustring completions boundary
+ unquote requote)
+ (when completions
+ (pcase-let*
+ ((prefix
+ (let ((completion-regexp-list nil))
+ (try-completion "" (cons (substring ustring boundary)
+ completions))))
+ (`(,qfullpos . ,qfun)
+ (funcall requote (+ boundary (length prefix)) string))
+ (qfullprefix (substring string 0 qfullpos))
+ (_ (assert (completion--string-equal-p
+ (funcall unquote qfullprefix)
+ (concat (substring ustring 0 boundary) prefix))
+ t))
+ (qboundary (car (funcall requote boundary string)))
+ (_ (assert (<= qboundary qfullpos)))
+ ;; FIXME: this split/quote/concat business messes up the carefully
+ ;; placed completions-common-part and completions-first-difference
+ ;; faces. We could try within the mapcar loop to search for the
+ ;; boundaries of those faces, pass them to `requote' to find their
+ ;; equivalent positions in the quoted output and re-add the faces:
+ ;; this might actually lead to correct results but would be
+ ;; pretty expensive.
+ ;; The better solution is to not quote the *Completions* display,
+ ;; which nicely circumvents the problem. The solution I used here
+ ;; instead is to hope that `qfun' preserves the text-properties and
+ ;; presume that the `first-difference' is not within the `prefix';
+ ;; this presumption is not always true, but at least in practice it is
+ ;; true in most cases.
+ (qprefix (propertize (substring qfullprefix qboundary)
+ 'face 'completions-common-part)))
+
+ ;; Here we choose to quote all elements returned, but a better option
+ ;; would be to return unquoted elements together with a function to
+ ;; requote them, so that *Completions* can show nicer unquoted values
+ ;; which only get quoted when needed by choose-completion.
+ (nconc
+ (mapcar (lambda (completion)
+ (assert (string-prefix-p prefix completion 'ignore-case) t)
+ (let* ((new (substring completion (length prefix)))
+ (qnew (funcall qfun new))
+ (qcompletion (concat qprefix qnew)))
+ (assert
+ (completion--string-equal-p
+ (funcall unquote
+ (concat (substring string 0 qboundary)
+ qcompletion))
+ (concat (substring ustring 0 boundary)
+ completion))
+ t)
+ qcompletion))
+ completions)
+ qboundary))))
+