-;;; 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-2013 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <abraham@dina.kvl.dk>
;; Maintainer: FSF
(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)))
"Extract the default external value of WIDGET."
(widget-apply widget :value-to-external
(or (widget-get widget :value)
- (widget-apply widget :default-get))))
+ (progn
+ (when (widget-get widget :args)
+ (let (args)
+ (dolist (arg (widget-get widget :args))
+ (setq args (append args
+ (if (widget-get arg :inline)
+ (widget-get arg :args)
+ (list arg)))))
+ (widget-put widget :args args)))
+ (widget-apply widget :default-get)))))
(defun widget-match-inline (widget vals)
"In WIDGET, match the start of VALS."
"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."
(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)
"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.
: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
(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."
(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
(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)))
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))
(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.
(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
: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)))
: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
(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
: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
(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
"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
: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"
(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-")
: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
: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)
(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)