comparison lisp/wid-edit.el @ 17550:d6545cfb6c5a

Synched with custom 1.90.

17549:f57de209f01b

;;
;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Keywords: extensions
;; Version: 1.84
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify

;;; Code:

(require 'widget)

(eval-when-compile
  (require 'cl))

;;; Compatibility.

(eval-and-compile
  (autoload 'pp-to-string "pp")

  (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
    ;; We have the old custom-library, hack around it!
    (defmacro defgroup (&rest args) nil)
    (defmacro defcustom (var value doc &rest args) 
      `(defvar ,var ,value ,doc))
    (defmacro defface (&rest args) nil)
    (define-widget-keywords :prefix :tag :load :link :options :type :group)
    (when (fboundp 'copy-face)
      (copy-face 'default 'widget-documentation-face)
      (copy-face 'bold 'widget-button-face)

  :type 'face
  :group 'widgets)

(defface widget-field-face '((((class grayscale color)
			       (background light))
			      (:background "light gray"))
			     (((class grayscale color)
			       (background dark))
			      (:background "dark gray"))
			     (t 
			      (:italic t)))

(defun widget-choose (title items &optional event)
  "Choose an item from a list.

First argument TITLE is the name of the list.
Second argument ITEMS is an alist (NAME . VALUE).
Optional third argument EVENT is an input event.

The user is asked to choose between each NAME from the items alist,
and the VALUE of the chosen element will be returned.  If EVENT is a
mouse event, and the number of elements in items is less than

	 (let ((val (get-popup-menu-response
		     (cons title
			   (mapcar
			    (function
			     (lambda (x)
			       (vector (car x) (list (car x)) t)))
			    items)))))
	   (setq val (and val
			  (listp (event-object val))
			  (stringp (car-safe (event-object val)))
			  (car (event-object val))))
	   (cdr (assoc val items))))
	(t
	 (let ((val (completing-read (concat title ": ") items nil t)))
	   (if (stringp val)
	       (let ((try (try-completion val items)))
		 (when (stringp try)
		   (setq val try))

	(setq child (car children)
	      children (cdr children))
	(when (eq (widget-get child :button) widget)
	  (throw 'child child)))
      nil)))

;;; Widget text specifications.
;; 
;; These functions are for specifying text properties. 

  (add-text-properties from to (list 'widget-doc widget
				     'face 'widget-documentation-face)))

(defmacro widget-specify-insert (&rest form)
  ;; Execute FORM without inheriting any text properties.
  `(save-restriction
     (let ((inhibit-read-only t)
	   result
	   after-change-functions)
       (insert "<>")
       (narrow-to-region (- (point) 2) (point))
       (widget-specify-none (point-min) (point-max))
       (goto-char (1+ (point-min)))
       (setq result (progn ,@form))
       (delete-region (point-min) (1+ (point-min)))
       (delete-region (1- (point-max)) (point-max))
       (goto-char (point-max))
       result)))

(defface widget-inactive-face '((((class grayscale color)
				  (background dark))
				 (:foreground "light gray"))
				(((class grayscale color)

(defun widget-specify-inactive (widget from to)
  "Make WIDGET inactive for user modifications."
  (unless (widget-get widget :inactive)
    (let ((overlay (make-overlay from to nil t nil)))
      (overlay-put overlay 'face 'widget-inactive-face)
      (overlay-put overlay 'evaporate 't)
      (overlay-put overlay (if (string-match "XEmacs" emacs-version)
			       'read-only
			     'modification-hooks) '(widget-overlay-inactive))
      (widget-put widget :inactive overlay))))

(defun widget-apply-action (widget &optional event)
  "Apply :action in WIDGET in response to EVENT."
  (if (widget-apply widget :active)
      (widget-apply widget :action event)
    (error "Attempt to perform action on inactive widget")))
    
;;; Glyphs.

(defcustom widget-glyph-directory (concat data-directory "custom/")
  "Where widget glyphs are located.
If this variable is nil, widget will try to locate the directory

		       (button (goto-char button))
		       (field (goto-char field))
		       (t
			(error "No buttons or fields found"))))))
	(setq button (widget-at (point)))
	(if (and button (widget-get button :tab-order)
		 (< (widget-get button :tab-order) 0))
	    (setq arg (1+ arg))))))
  (while (< arg 0)
    (if (= (point-min) (point))
	(forward-char 1))
    (setq arg (1+ arg))

      (cond ((and button field)
	     (goto-char (max button field)))
	    (button (goto-char button))
	    (field (goto-char field)))
      (setq button (widget-at (point)))
      (if (and button (widget-get button :tab-order)
	       (< (widget-get button :tab-order) 0))
	  (setq arg (1- arg)))))
  (widget-echo-help (point))
  (run-hooks 'widget-move-hook))

(defun widget-forward (arg)

  :validate (lambda (widget) nil)
  :active 'widget-default-active
  :activate 'widget-specify-active
  :deactivate 'widget-default-deactivate
  :action 'widget-default-action
  :notify 'widget-default-notify)

(defun widget-default-create (widget)
  "Create WIDGET at point in the current buffer."
  (widget-specify-insert
   (let ((from (point))

	 (to (copy-marker (point-max))))
     (widget-specify-text from to)
     (set-marker-insertion-type from t)
     (set-marker-insertion-type to nil)
     (widget-put widget :from from)
     (widget-put widget :to to))))

(defun widget-default-format-handler (widget escape)
  ;; We recognize the %h escape by default.
  (let* ((buttons (widget-get widget :buttons))
	 (doc-property (widget-get widget :documentation-property))

    (widget-apply widget :value-delete)
    (when (< from to)
      ;; Kludge: this doesn't need to be true for empty formats.
      (delete-region from to))
    (set-marker from nil)
    (set-marker to nil)))

(defun widget-default-value-set (widget value)
  ;; Recreate widget with new value.
  (save-excursion
    (goto-char (widget-get widget :from))

      (widget-apply parent :notify widget event))))

(defun widget-default-notify (widget child &optional event)
  ;; Pass notification to parent.
  (widget-default-action widget event))

;;; The `item' Widget.

(define-widget 'item 'default
  "Constant items for inclusion in other widgets."

  "A link to an info file."
  :action 'widget-info-link-action)

(defun widget-info-link-action (widget &optional event)
  "Open the info node specified by WIDGET."
  (Info-goto-node (widget-value widget)))

;;; The `url-link' Widget.

(define-widget 'url-link 'link
  "A link to an www page."

		 (widget-choose tag (reverse choices) event))))
    (when current
      (widget-value-set widget 
			(widget-apply current :value-to-external
				      (widget-get current :value)))
    (widget-apply widget :notify widget event)
    (widget-setup)))
  ;; Notify parent.
  (widget-apply widget :notify widget event)
  (widget-clear-undo))

(defun widget-choice-validate (widget)
  ;; Valid if we have made a valid choice.
  (let ((void (widget-get widget :void))
	(choice (widget-get widget :choice))

(defun widget-toggle-action (widget &optional event)
  ;; Toggle value.
  (widget-value-set widget (not (widget-value widget)))
  (widget-apply widget :notify widget event))
  
;;; The `checkbox' Widget.

(define-widget 'checkbox 'toggle
  "A checkbox toggle."
  :format "%[%v%]"

;;; The Sexp Widgets.

(define-widget 'const 'item
  "An immutable sexp."
  :format "%t\n%d")

(define-widget 'function-item 'item
  "An immutable function name."
  :format "%v\n%h"
  :documentation-property (lambda (symbol)
			    (condition-case nil
				(documentation symbol t)
			      (error nil))))

(define-widget 'variable-item 'item
  "An immutable variable name."
  :format "%v\n%h"
  :documentation-property 'variable-documentation)

(define-widget 'string 'editable-field
  "A string"
  :tag "String"
  :format "%[%t%]: %v")

(define-widget 'regexp 'string
  "A regular expression."
  ;; Should do validation.
  :tag "Regexp")

(define-widget 'file 'string
  "A file widget.  
It will read a file name from the minibuffer when activated."
  :format "%[%t%]: %v"
  :tag "File"
  :action 'widget-file-action)

(defun widget-file-action (widget &optional event)
  ;; Read a file name from the minibuffer.
  (let* ((value (widget-value widget))
	 (dir (file-name-directory value))

  :tag "Lisp expression"
  :value nil
  :validate 'widget-sexp-validate
  :match (lambda (widget value) t)
  :value-to-internal 'widget-sexp-value-to-internal
  :value-to-external (lambda (widget value) (read value)))

(defun widget-sexp-value-to-internal (widget value)
  ;; Use pp for printer representation.
  (let ((pp (pp-to-string value)))
    (while (string-match "\n\\'" pp)

							   (point-max))))
	      widget))
	(error (widget-put widget :error (error-message-string data))
	       widget)))))

(define-widget 'integer 'sexp
  "An integer."
  :tag "Integer"
  :value 0
  :type-error "This field should contain an integer"

  "An character."
  :tag "Character"
  :value 0
  :size 1 
  :format "%{%t%}: %v\n"
  :type-error "This field should contain a character"
  :value-to-internal (lambda (widget value)
		       (if (integerp value) 
			   (char-to-string value)
			 value))
  :value-to-external (lambda (widget value)

  :format "%{%t%}:\n%v")

(define-widget 'boolean 'toggle
  "To be nil or non-nil, that is the question."
  :tag "Boolean"
  :format "%{%t%}: %[%v%]\n")

;;; The `color' Widget.

(define-widget 'color-item 'choice-item
  "A color name (with sample)."

17550:d6545cfb6c5a

;;
;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Keywords: extensions
;; Version: 1.90
;; X-URL: http://www.dina.kvl.dk/~abraham/custom/

;; This file is part of GNU Emacs.

;; GNU Emacs is free software; you can redistribute it and/or modify

;;; Code:

(require 'widget)

(eval-when-compile (require 'cl))

;;; Compatibility.

(eval-and-compile
  (autoload 'pp-to-string "pp")

  (unless (and (featurep 'custom) (fboundp 'custom-declare-variable))
    ;; We have the old custom-library, hack around it!
    (defmacro defgroup (&rest args) nil)
    (defmacro defcustom (var value doc &rest args) 
      (` (defvar (, var) (, value) (, doc))))
    (defmacro defface (&rest args) nil)
    (define-widget-keywords :prefix :tag :load :link :options :type :group)
    (when (fboundp 'copy-face)
      (copy-face 'default 'widget-documentation-face)
      (copy-face 'bold 'widget-button-face)

  :type 'face
  :group 'widgets)

(defface widget-field-face '((((class grayscale color)
			       (background light))
			      (:background "gray85"))
			     (((class grayscale color)
			       (background dark))
			      (:background "dark gray"))
			     (t 
			      (:italic t)))

(defun widget-choose (title items &optional event)
  "Choose an item from a list.

First argument TITLE is the name of the list.
Second argument ITEMS is an list whose members are either
 (NAME . VALUE), to indicate selectable items, or just strings to
 indicate unselectable items.
Optional third argument EVENT is an input event.

The user is asked to choose between each NAME from the items alist,
and the VALUE of the chosen element will be returned.  If EVENT is a
mouse event, and the number of elements in items is less than

	 (let ((val (get-popup-menu-response
		     (cons title
			   (mapcar
			    (function
			     (lambda (x)
			       (if (stringp x)
				   (vector x nil nil) 
				 (vector (car x) (list (car x)) t))))
			    items)))))
	   (setq val (and val
			  (listp (event-object val))
			  (stringp (car-safe (event-object val)))
			  (car (event-object val))))
	   (cdr (assoc val items))))
	(t
	 (setq items (remove-if 'stringp items))
	 (let ((val (completing-read (concat title ": ") items nil t)))
	   (if (stringp val)
	       (let ((try (try-completion val items)))
		 (when (stringp try)
		   (setq val try))

	(setq child (car children)
	      children (cdr children))
	(when (eq (widget-get child :button) widget)
	  (throw 'child child)))
      nil)))

;;; Helper functions.
;;
;; These are widget specific.

;;;###autoload
(defun widget-prompt-value (widget prompt &optional value unbound)
  "Prompt for a value matching WIDGET, using PROMPT.
The current value is assumed to be VALUE, unless UNBOUND is non-nil."
  (unless (listp widget)
    (setq widget (list widget)))
  (setq widget (widget-convert widget))
  (let ((answer (widget-apply widget :prompt-value prompt value unbound)))
    (unless (widget-apply widget :match answer)
      (error "Value does not match %S type." (car widget)))
    answer))

;;; Widget text specifications.
;; 
;; These functions are for specifying text properties. 

  (add-text-properties from to (list 'widget-doc widget
				     'face 'widget-documentation-face)))

(defmacro widget-specify-insert (&rest form)
  ;; Execute FORM without inheriting any text properties.
  (`
   (save-restriction
     (let ((inhibit-read-only t)
	   result
	   after-change-functions)
       (insert "<>")
       (narrow-to-region (- (point) 2) (point))
       (widget-specify-none (point-min) (point-max))
       (goto-char (1+ (point-min)))
       (setq result (progn (,@ form)))
       (delete-region (point-min) (1+ (point-min)))
       (delete-region (1- (point-max)) (point-max))
       (goto-char (point-max))
       result))))

(defface widget-inactive-face '((((class grayscale color)
				  (background dark))
				 (:foreground "light gray"))
				(((class grayscale color)

(defun widget-specify-inactive (widget from to)
  "Make WIDGET inactive for user modifications."
  (unless (widget-get widget :inactive)
    (let ((overlay (make-overlay from to nil t nil)))
      (overlay-put overlay 'face 'widget-inactive-face)
      (overlay-put overlay 'evaporate t)
      (overlay-put overlay 'priority 100)
      (overlay-put overlay (if (string-match "XEmacs" emacs-version)
			       'read-only
			     'modification-hooks) '(widget-overlay-inactive))
      (widget-put widget :inactive overlay))))

(defun widget-apply-action (widget &optional event)
  "Apply :action in WIDGET in response to EVENT."
  (if (widget-apply widget :active)
      (widget-apply widget :action event)
    (error "Attempt to perform action on inactive widget")))

;;; Glyphs.

(defcustom widget-glyph-directory (concat data-directory "custom/")
  "Where widget glyphs are located.
If this variable is nil, widget will try to locate the directory

		       (button (goto-char button))
		       (field (goto-char field))
		       (t
			(error "No buttons or fields found"))))))
	(setq button (widget-at (point)))
	(if (or (and button (widget-get button :tab-order)
		     (< (widget-get button :tab-order) 0))
		(and button (not (widget-apply button :active))))
	    (setq arg (1+ arg))))))
  (while (< arg 0)
    (if (= (point-min) (point))
	(forward-char 1))
    (setq arg (1+ arg))

      (cond ((and button field)
	     (goto-char (max button field)))
	    (button (goto-char button))
	    (field (goto-char field)))
      (setq button (widget-at (point)))
      (if (or (and button (widget-get button :tab-order)
		   (< (widget-get button :tab-order) 0))
	      (and button (not (widget-apply button :active))))
	  (setq arg (1- arg)))))
  (widget-echo-help (point))
  (run-hooks 'widget-move-hook))

(defun widget-forward (arg)

  :validate (lambda (widget) nil)
  :active 'widget-default-active
  :activate 'widget-specify-active
  :deactivate 'widget-default-deactivate
  :action 'widget-default-action
  :notify 'widget-default-notify
  :prompt-value 'widget-default-prompt-value)

(defun widget-default-create (widget)
  "Create WIDGET at point in the current buffer."
  (widget-specify-insert
   (let ((from (point))

	 (to (copy-marker (point-max))))
     (widget-specify-text from to)
     (set-marker-insertion-type from t)
     (set-marker-insertion-type to nil)
     (widget-put widget :from from)
     (widget-put widget :to to)))
  (widget-clear-undo))

(defun widget-default-format-handler (widget escape)
  ;; We recognize the %h escape by default.
  (let* ((buttons (widget-get widget :buttons))
	 (doc-property (widget-get widget :documentation-property))

    (widget-apply widget :value-delete)
    (when (< from to)
      ;; Kludge: this doesn't need to be true for empty formats.
      (delete-region from to))
    (set-marker from nil)
    (set-marker to nil))
  (widget-clear-undo))

(defun widget-default-value-set (widget value)
  ;; Recreate widget with new value.
  (save-excursion
    (goto-char (widget-get widget :from))

      (widget-apply parent :notify widget event))))

(defun widget-default-notify (widget child &optional event)
  ;; Pass notification to parent.
  (widget-default-action widget event))

(defun widget-default-prompt-value (widget prompt value unbound)
  ;; Read an arbitrary value.  Stolen from `set-variable'.
;;  (let ((initial (if unbound
;;		     nil
;;		   ;; It would be nice if we could do a `(cons val 1)' here.
;;		   (prin1-to-string (custom-quote value))))))
  (eval-minibuffer prompt ))

;;; The `item' Widget.

(define-widget 'item 'default
  "Constant items for inclusion in other widgets."

  "A link to an info file."
  :action 'widget-info-link-action)

(defun widget-info-link-action (widget &optional event)
  "Open the info node specified by WIDGET."
  (Info-goto-node (widget-value widget))
  ;; Steal button release event.
  (if (and (fboundp 'button-press-event-p)
	   (fboundp 'next-command-event))
      ;; XEmacs
      (and event
	   (button-press-event-p event)
	   (next-command-event))
    ;; Emacs
    (when (memq 'down (event-modifiers event))
      (read-event))))

;;; The `url-link' Widget.

(define-widget 'url-link 'link
  "A link to an www page."

		 (widget-choose tag (reverse choices) event))))
    (when current
      (widget-value-set widget 
			(widget-apply current :value-to-external
				      (widget-get current :value)))
      (widget-apply widget :notify widget event)
      (widget-setup))))

(defun widget-choice-validate (widget)
  ;; Valid if we have made a valid choice.
  (let ((void (widget-get widget :void))
	(choice (widget-get widget :choice))

(defun widget-toggle-action (widget &optional event)
  ;; Toggle value.
  (widget-value-set widget (not (widget-value widget)))
  (widget-apply widget :notify widget event))

;;; The `checkbox' Widget.

(define-widget 'checkbox 'toggle
  "A checkbox toggle."
  :format "%[%v%]"

;;; The Sexp Widgets.

(define-widget 'const 'item
  "An immutable sexp."
  :prompt-value 'widget-const-prompt-value
  :format "%t\n%d")

(defun widget-const-prompt-value (widget prompt value unbound)
  ;; Return the value of the const.
  (widget-value widget))

(define-widget 'function-item 'const
  "An immutable function name."
  :format "%v\n%h"
  :documentation-property (lambda (symbol)
			    (condition-case nil
				(documentation symbol t)
			      (error nil))))

(define-widget 'variable-item 'const
  "An immutable variable name."
  :format "%v\n%h"
  :documentation-property 'variable-documentation)

(define-widget 'string 'editable-field
  "A string"
  :prompt-value 'widget-string-prompt-value
  :tag "String"
  :format "%[%t%]: %v")

(defvar widget-string-prompt-value-history nil
  "History of input to `widget-string-prompt-value'.")

(defun widget-string-prompt-value (widget prompt value unbound)
  ;; Read a string.
  (read-string prompt (if unbound nil (cons value 1))
	       'widget-string-prompt-value-history))

(define-widget 'regexp 'string
  "A regular expression."
  :match 'widget-regexp-match
  :validate 'widget-regexp-validate
  :tag "Regexp")

(defun widget-regexp-match (widget value)
  ;; Match valid regexps.
  (and (stringp value)
       (condition-case data
	   (prog1 t
	     (string-match value ""))
	 (error nil))))

(defun widget-regexp-validate (widget)
  "Check that the value of WIDGET is a valid regexp."
  (let ((val (widget-value widget)))
    (condition-case data
	(prog1 nil
	  (string-match val ""))
      (error (widget-put widget :error (error-message-string data))
	     widget))))

(define-widget 'file 'string
  "A file widget.  
It will read a file name from the minibuffer when activated."
  :prompt-value 'widget-file-prompt-value
  :format "%[%t%]: %v"
  :tag "File"
  :action 'widget-file-action)

(defun widget-file-prompt-value (widget prompt value unbound)
  ;; Read file from minibuffer.
  (abbreviate-file-name
   (if unbound
       (read-file-name prompt)
     (let ((prompt2 (concat prompt "(default `" value "') "))
	   (dir (file-name-directory value))
	   (file (file-name-nondirectory value))
	   (must-match (widget-get widget :must-match)))
       (read-file-name prompt2 dir nil must-match file)))))

(defun widget-file-action (widget &optional event)
  ;; Read a file name from the minibuffer.
  (let* ((value (widget-value widget))
	 (dir (file-name-directory value))

  :tag "Lisp expression"
  :value nil
  :validate 'widget-sexp-validate
  :match (lambda (widget value) t)
  :value-to-internal 'widget-sexp-value-to-internal
  :value-to-external (lambda (widget value) (read value))
  :prompt-value 'widget-sexp-prompt-value)

(defun widget-sexp-value-to-internal (widget value)
  ;; Use pp for printer representation.
  (let ((pp (pp-to-string value)))
    (while (string-match "\n\\'" pp)

							   (point-max))))
	      widget))
	(error (widget-put widget :error (error-message-string data))
	       widget)))))

(defvar widget-sexp-prompt-value-history nil
  "History of input to `widget-sexp-prompt-value'.")

(defun widget-sexp-prompt-value (widget prompt value unbound)
  ;; Read an arbitrary sexp.
  (let ((found (read-string prompt
			    (if unbound nil (cons (prin1-to-string value) 1))
			    'widget-sexp-prompt-value)))
    (let ((buffer (set-buffer (get-buffer-create " *Widget Scratch*"))))
      (erase-buffer)
      (insert found)
      (goto-char (point-min))
      (let ((answer (read buffer)))
	(unless (eobp)
	  (error "Junk at end of expression: %s"
		 (buffer-substring (point) (point-max))))
	answer))))
  
(define-widget 'integer 'sexp
  "An integer."
  :tag "Integer"
  :value 0
  :type-error "This field should contain an integer"

  "An character."
  :tag "Character"
  :value 0
  :size 1 
  :format "%{%t%}: %v\n"
  :valid-regexp "\\`.\\'"
  :error "This field should contain a single character"
  :value-to-internal (lambda (widget value)
		       (if (integerp value) 
			   (char-to-string value)
			 value))
  :value-to-external (lambda (widget value)

  :format "%{%t%}:\n%v")

(define-widget 'boolean 'toggle
  "To be nil or non-nil, that is the question."
  :tag "Boolean"
  :prompt-value 'widget-boolean-prompt-value
  :format "%{%t%}: %[%v%]\n")

(defun widget-boolean-prompt-value (widget prompt value unbound)
  ;; Toggle a boolean.
  (cond (unbound
	 (y-or-n-p prompt))
	(value
	 (message "Off")
	 nil)
	(t
	 (message "On")
	 t)))

;;; The `color' Widget.

(define-widget 'color-item 'choice-item
  "A color name (with sample)."