-;;; 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)))
"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)))
(while vals
(let ((answer (widget-checklist-match-up args vals)))
(cond (answer
- (let ((vals (widget-match-inline answer vals)))
- (setq found (append found (car vals))
- vals (cdr vals)
+ (let ((vals2 (widget-match-inline answer vals)))
+ (setq found (append found (car vals2))
+ vals (cdr vals2)
args (delq answer args))))
(greedy
(setq rest (append rest (list (car vals)))
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)
HCoop / bpt / emacs.git / blobdiff