X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/db0406bb64f7e5dceeb257c7e350f1e80ed9c1c1..af39894ab4b8a68eef14b39c030577b419a582a8:/lisp/wid-edit.el diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 7b7813db94..9c5c6462bc 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -1,6 +1,6 @@ -;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t;-*- +;;; wid-edit.el --- Functions for creating and using widgets -*-byte-compile-dynamic: t; lexical-binding:t -*- ;; -;; Copyright (C) 1996-1997, 1999-2011 Free Software Foundation, Inc. +;; Copyright (C) 1996-1997, 1999-2012 Free Software Foundation, Inc. ;; ;; Author: Per Abrahamsen ;; Maintainer: FSF @@ -295,10 +295,10 @@ minibuffer." (error "Canceled")) value)))) -(defun widget-remove-if (predictate list) +(defun widget-remove-if (predicate list) (let (result (tail list)) (while tail - (or (funcall predictate (car tail)) + (or (funcall predicate (car tail)) (setq result (cons (car tail) result))) (setq tail (cdr tail))) (nreverse result))) @@ -577,7 +577,7 @@ This is only meaningful for radio buttons or checkboxes in a list." "Map FUNCTION over the buttons in BUFFER. FUNCTION is called with the arguments WIDGET and MAPARG. -If FUNCTION returns non-nil, the walk is cancelled. +If FUNCTION returns non-nil, the walk is canceled. The arguments MAPARG, and BUFFER default to nil and (current-buffer), respectively." @@ -1141,12 +1141,6 @@ the field." (kill-region (point) end) (call-interactively 'kill-line)))) -(defcustom widget-complete-field (lookup-key global-map "\M-\t") - "Default function to call for completion inside fields." - :options '(ispell-complete-word complete-tag lisp-complete-symbol) - :type 'function - :group 'widgets) - (defun widget-narrow-to-field () "Narrow to field." (interactive) @@ -1161,10 +1155,25 @@ the field." "Complete content of editable field from point. When not inside a field, signal an error." (interactive) + (let ((data (widget-completions-at-point))) + (cond + ((functionp data) (funcall data)) + ((consp data) + (let ((completion-extra-properties (nth 3 data))) + (completion-in-region (nth 0 data) (nth 1 data) (nth 2 data) + (plist-get completion-extra-properties + :predicate)))) + (t + (error "Not in an editable field"))))) +;; We may want to use widget completion in buffers where the major mode +;; hasn't added widget-completions-at-point to completion-at-point-functions, +;; so it's not really obsolete (yet). +;; (make-obsolete 'widget-complete 'completion-at-point "24.1") + +(defun widget-completions-at-point () (let ((field (widget-field-find (point)))) - (if field - (widget-apply field :complete) - (error "Not in an editable field")))) + (when field + (widget-apply field :completions-function)))) ;;; Setting up the buffer. @@ -1435,7 +1444,7 @@ The value of the :type attribute should be an unconverted widget type." :value-to-external (lambda (_widget value) value) :button-prefix 'widget-button-prefix :button-suffix 'widget-button-suffix - :complete 'widget-default-complete + :completions-function #'widget-default-completions :create 'widget-default-create :indent nil :offset 0 @@ -1461,13 +1470,20 @@ The value of the :type attribute should be an unconverted widget type." (defvar widget--completing-widget) -(defun widget-default-complete (widget) - "Call the value of the :complete-function property of WIDGET. -If that does not exist, call the value of `widget-complete-field'. -During this call, `widget--completing-widget' is bound to WIDGET." - (let ((widget--completing-widget widget)) - (call-interactively (or (widget-get widget :complete-function) - widget-complete-field)))) +(defun widget-default-completions (widget) + "Return completion data, like `completion-at-point-functions' would." + (let ((completions (widget-get widget :completions))) + (if completions + (list (widget-field-start widget) + (max (point) (widget-field-text-end widget)) + completions) + (if (widget-get widget :complete) + (lambda () (widget-apply widget :complete)) + (if (widget-get widget :complete-function) + (lambda () + (let ((widget--completing-widget widget)) + (call-interactively + (widget-get widget :complete-function))))))))) (defun widget-default-create (widget) "Create WIDGET at point in the current buffer." @@ -1661,7 +1677,7 @@ During this call, `widget--completing-widget' is bound to WIDGET." (eval-minibuffer prompt)) (defun widget-docstring (widget) - "Return the documentation string specificied by WIDGET, or nil if none. + "Return the documentation string specified by WIDGET, or nil if none. If WIDGET has a `:doc' property, that specifies the documentation string. Otherwise, try the `:documentation-property' property. If this is a function, call it with the widget's value as an argument; if @@ -1961,10 +1977,14 @@ the earlier input." (when (overlayp overlay) (delete-overlay overlay)))) -(defun widget-field-value-get (widget) - "Return current text in editing field." +(defun widget-field-value-get (widget &optional no-truncate) + "Return current text in editing field. +Normally, trailing spaces within the editing field are truncated. +But if NO-TRUNCATE is non-nil, include them." (let ((from (widget-field-start widget)) - (to (widget-field-text-end widget)) + (to (if no-truncate + (widget-field-end widget) + (widget-field-text-end widget))) (buffer (widget-field-buffer widget)) (secret (widget-get widget :secret)) (old (current-buffer))) @@ -2337,7 +2357,7 @@ Return an alist of (TYPE MATCH)." result)) (defun widget-checklist-validate (widget) - ;; Ticked chilren must be valid. + ;; Ticked children must be valid. (let ((children (widget-get widget :children)) child button found) (while (and children (not found)) @@ -2887,15 +2907,7 @@ link for that string." (push (widget-convert-button widget-documentation-link-type begin end :value name) buttons))))) - (widget-put widget :buttons buttons))) - (let ((indent (widget-get widget :indent))) - (when (and indent (not (zerop indent))) - (save-excursion - (save-restriction - (narrow-to-region from to) - (goto-char (point-min)) - (while (search-forward "\n" nil t) - (insert-char ?\s indent))))))) + (widget-put widget :buttons buttons)))) ;;; The `documentation-string' Widget. @@ -2914,10 +2926,9 @@ link for that string." (start (point))) (if (string-match "\n" doc) (let ((before (substring doc 0 (match-beginning 0))) - (after (substring doc (match-beginning 0))) - button) - (when (and indent (not (zerop indent))) - (insert-char ?\s indent)) + (after (substring doc (match-end 0))) + button end) + (widget-documentation-string-indent-to indent) (insert before ?\s) (widget-documentation-link-add widget start (point)) (setq button @@ -2930,18 +2941,35 @@ link for that string." :action 'widget-parent-action shown)) (when shown + (insert ?\n) (setq start (point)) (when (and indent (not (zerop indent))) (insert-char ?\s indent)) (insert after) - (widget-documentation-link-add widget start (point))) + (setq end (point)) + (widget-documentation-link-add widget start end) + ;; Indent the subsequent lines. + (when (and indent (> indent 0)) + (save-excursion + (save-restriction + (narrow-to-region start end) + (goto-char (point-min)) + (while (search-forward "\n" nil t) + (widget-documentation-string-indent-to indent)))))) (widget-put widget :buttons (list button))) - (when (and indent (not (zerop indent))) - (insert-char ?\s indent)) + (widget-documentation-string-indent-to indent) (insert doc) (widget-documentation-link-add widget start (point)))) (insert ?\n)) +(defun widget-documentation-string-indent-to (col) + (when (and (numberp col) + (> col 0)) + (let ((opoint (point))) + (indent-to col) + (put-text-property opoint (point) + 'display `(space :align-to ,col))))) + (defun widget-documentation-string-action (widget &rest _ignore) ;; Toggle documentation. (let ((parent (widget-get widget :parent))) @@ -3018,20 +3046,6 @@ as the value." :complete-function 'ispell-complete-word :prompt-history 'widget-string-prompt-value-history) -(defun widget-string-complete () - "Complete contents of string field. -Completions are taken from the :completion-alist property of the -widget. If that isn't a list, it's evalled and expected to yield a list." - (interactive) - (let* ((widget widget--completing-widget) - (completion-ignore-case (widget-get widget :completion-ignore-case)) - (alist (widget-get widget :completion-alist)) - (_ (unless (listp alist) - (setq alist (eval alist))))) - (completion-in-region (widget-field-start widget) - (max (point) (widget-field-text-end widget)) - alist))) - (define-widget 'regexp 'string "A regular expression." :match 'widget-regexp-match @@ -3059,21 +3073,13 @@ widget. If that isn't a list, it's evalled and expected to yield a list." (define-widget 'file 'string "A file widget. It reads a file name from an editable text field." - :complete-function 'widget-file-complete + :completions #'completion-file-name-table :prompt-value 'widget-file-prompt-value :format "%{%t%}: %v" ;; Doesn't work well with terminating newline. ;; :value-face 'widget-single-line-field :tag "File") -(defun widget-file-complete () - "Perform completion on file name preceding point." - (interactive) - (let ((widget widget--completing-widget)) - (completion-in-region (widget-field-start widget) - (max (point) (widget-field-text-end widget)) - 'completion-file-name-table))) - (defun widget-file-prompt-value (widget prompt value unbound) ;; Read file from minibuffer. (abbreviate-file-name @@ -3113,7 +3119,7 @@ It reads a directory name from an editable text field." :tag "Symbol" :format "%{%t%}: %v" :match (lambda (_widget value) (symbolp value)) - :complete-function 'lisp-complete-symbol + :completions obarray :prompt-internal 'widget-symbol-prompt-internal :prompt-match 'symbolp :prompt-history 'widget-symbol-prompt-value-history @@ -3141,9 +3147,8 @@ It reads a directory name from an editable text field." (define-widget 'function 'restricted-sexp "A Lisp function." - :complete-function (lambda () - (interactive) - (lisp-complete-symbol 'fboundp)) + :completions (apply-partially #'completion-table-with-predicate + obarray #'fboundp 'strict) :prompt-value 'widget-field-prompt-value :prompt-internal 'widget-symbol-prompt-internal :prompt-match 'fboundp @@ -3165,9 +3170,8 @@ It reads a directory name from an editable text field." "A Lisp variable." :prompt-match 'boundp :prompt-history 'widget-variable-prompt-value-history - :complete-function (lambda () - (interactive) - (lisp-complete-symbol 'boundp)) + :completions (apply-partially #'completion-table-with-predicate + obarray #'boundp 'strict) :tag "Variable") (define-widget 'coding-system 'symbol @@ -3178,9 +3182,8 @@ It reads a directory name from an editable text field." :prompt-history 'coding-system-value-history :prompt-value 'widget-coding-system-prompt-value :action 'widget-coding-system-action - :complete-function (lambda () - (interactive) - (lisp-complete-symbol 'coding-system-p)) + :completions (apply-partially #'completion-table-with-predicate + obarray #'coding-system-p 'strict) :validate (lambda (widget) (unless (coding-system-p (widget-value widget)) (widget-put widget :error (format "Invalid coding system: %S" @@ -3317,7 +3320,7 @@ It reads a directory name from an editable text field." (insert (widget-apply widget :value-get)) (goto-char (point-min)) (let (err) - (condition-case data + (condition-case data ;Note: We get a spurious byte-compile warning here. (progn ;; Avoid a confusing end-of-file error. (skip-syntax-forward "\\s-") @@ -3406,6 +3409,7 @@ To use this type, you must define :match or :match-alternatives." :format "%{%t%}: %v\n" :valid-regexp "\\`.\\'" :error "This field should contain a single character" + :value-get (lambda (w) (widget-field-value-get w t)) :value-to-internal (lambda (_widget value) (if (stringp value) value @@ -3685,7 +3689,7 @@ example: :size 10 :tag "Color" :value "black" - :complete 'widget-color-complete + :completions (or facemenu-color-alist (defined-colors)) :sample-face-get 'widget-color-sample-face-get :notify 'widget-color-notify :action 'widget-color-action) @@ -3711,14 +3715,6 @@ example: (delete-window win))) (pop-to-buffer ,(current-buffer)))))) -(defun widget-color-complete (widget) - "Complete the color in WIDGET." - (require 'facemenu) ; for facemenu-color-alist - (completion-in-region (widget-field-start widget) - (max (point) (widget-field-text-end widget)) - (or facemenu-color-alist - (sort (defined-colors) 'string-lessp)))) - (defun widget-color-sample-face-get (widget) (let* ((value (condition-case nil (widget-value widget)