comparison lisp/wid-edit.el @ 24107:c222b0bea4f0

(plist, alist): New widget types. (coding-system): Define this unconditionally.

24106:ea58bb66d0e3

  (let ((parent (widget-get widget :parent)))
    (widget-put parent :documentation-shown 
		(not (widget-get parent :documentation-shown))))
  ;; Redraw.
  (widget-value-set widget (widget-value widget)))

;;; The Sexp Widgets.

(define-widget 'const 'item
  "An immutable sexp."
  :prompt-value 'widget-const-prompt-value

  "A Lisp variable."
  :prompt-match 'boundp
  :prompt-history 'widget-variable-prompt-value-history
  :tag "Variable")

(when (featurep 'mule)
  (defvar widget-coding-system-prompt-value-history nil
    "History of input to `widget-coding-system-prompt-value'.")
  
  (define-widget 'coding-system 'symbol
    "A MULE coding-system."
    :format "%{%t%}: %v"
    :tag "Coding system"
    :prompt-history 'widget-coding-system-prompt-value-history
    :prompt-value 'widget-coding-system-prompt-value
    :action 'widget-coding-system-action)
  
  (defun widget-coding-system-prompt-value (widget prompt value unbound)
    ;; Read coding-system from minibuffer.
    (intern
     (completing-read (format "%s (default %s) " prompt value)
		      (mapcar (function
			       (lambda (sym)
				 (list (symbol-name sym))
				 ))
			      (coding-system-list)))))

  (defun widget-coding-system-action (widget &optional event)
    ;; Read a file name from the minibuffer.
    (let ((answer
	   (widget-coding-system-prompt-value
	    widget
	    (widget-apply widget :menu-tag-get)
	    (widget-value widget)
	    t)))
      (widget-value-set widget answer)
      (widget-apply widget :notify widget event)
      (widget-setup)))
  )

(define-widget 'sexp 'editable-field
  "An arbitrary Lisp expression."
  :tag "Lisp expression"
  :format "%{%t%}: %v"
  :value nil

		      (eq (car (car alternatives)) 'quote))
		 (eq value (nth 1 (car alternatives)))))
	  (setq matched t))
      (setq alternatives (cdr alternatives)))
    matched))

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

(defun widget-cons-match (widget value) 
  (and (consp value)
       (widget-group-match widget
			   (widget-apply widget :value-to-internal value))))

(define-widget 'choice 'menu-choice
  "A union of several sexp types."
  :tag "Choice"
  :format "%{%t%}: %[Value Menu%] %v"
  :button-prefix 'widget-push-button-prefix

			 (cdr (assoc val choices)))
		     nil)))))
    (if current
	(widget-prompt-value current prompt nil t)
      value)))

(define-widget 'radio 'radio-button-choice
  "A union of several sexp types."
  :tag "Choice"
  :format "%{%t%}:\n%v"
  :prompt-value 'widget-choice-prompt-value)

  :off "off (nil)")

(defun widget-boolean-prompt-value (widget prompt value unbound)
  ;; Toggle a boolean.
  (y-or-n-p prompt))

;;; The `color' Widget.

(define-widget 'color 'editable-field 
  "Choose a color name (with sample)."
  :format "%t: %v (%{sample%})\n"

(defun widget-color-notify (widget child &optional event)
  "Update the sample, and notofy the parent."
  (overlay-put (widget-get widget :sample-overlay) 
	       'face (widget-apply widget :sample-face-get))
  (widget-default-notify widget child event))

;;; The Help Echo

(defun widget-echo-help-mouse ()
  "Display the help message for the widget under the mouse.
Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)"

24107:c222b0bea4f0

  (let ((parent (widget-get widget :parent)))
    (widget-put parent :documentation-shown 
		(not (widget-get parent :documentation-shown))))
  ;; Redraw.
  (widget-value-set widget (widget-value widget)))

;;; The Sexp Widgets.

(define-widget 'const 'item
  "An immutable sexp."
  :prompt-value 'widget-const-prompt-value

  "A Lisp variable."
  :prompt-match 'boundp
  :prompt-history 'widget-variable-prompt-value-history
  :tag "Variable")

(defvar widget-coding-system-prompt-value-history nil
  "History of input to `widget-coding-system-prompt-value'.")
  
(define-widget 'coding-system 'symbol
  "A MULE coding-system."
  :format "%{%t%}: %v"
  :tag "Coding system"
  :prompt-history 'widget-coding-system-prompt-value-history
  :prompt-value 'widget-coding-system-prompt-value
  :action 'widget-coding-system-action)
  
(defun widget-coding-system-prompt-value (widget prompt value unbound)
  ;; Read coding-system from minibuffer.
  (intern
   (completing-read (format "%s (default %s) " prompt value)
		    (mapcar (function
			     (lambda (sym)
			       (list (symbol-name sym))
			       ))
			    (coding-system-list)))))

(defun widget-coding-system-action (widget &optional event)
  ;; Read a file name from the minibuffer.
  (let ((answer
	 (widget-coding-system-prompt-value
	  widget
	  (widget-apply widget :menu-tag-get)
	  (widget-value widget)
	  t)))
    (widget-value-set widget answer)
    (widget-apply widget :notify widget event)
    (widget-setup)))
  )

(define-widget 'sexp 'editable-field
  "An arbitrary Lisp expression."
  :tag "Lisp expression"
  :format "%{%t%}: %v"
  :value nil

		      (eq (car (car alternatives)) 'quote))
		 (eq value (nth 1 (car alternatives)))))
	  (setq matched t))
      (setq alternatives (cdr alternatives)))
    matched))

(define-widget 'integer 'restricted-sexp
  "An integer."
  :tag "Integer"
  :value 0
  :type-error "This field should contain an integer"

(defun widget-cons-match (widget value) 
  (and (consp value)
       (widget-group-match widget
			   (widget-apply widget :value-to-internal value))))

;;; The `plist' Widget.
;;
;; Property lists.

(define-widget 'plist 'list
  "A property list."
  :key-type '(symbol :tag "Key")
  :value-type '(sexp :tag "Value")
  :convert-widget 'widget-plist-convert-widget
  :tag "Plist")

(defvar widget-plist-value-type)	;Dynamic variable

(defun widget-plist-convert-widget (widget)
  ;; Handle `:options'.
  (let* ((options (widget-get widget :options))
	 (key-type (widget-get widget :key-type))
	 (widget-plist-value-type (widget-get widget :value-type))
	 (other `(editable-list :inline t 
				(group :inline t
				       ,key-type
				       ,widget-plist-value-type)))
	 (args (if options
		   (list `(checklist :inline t
				     :greedy t
				     ,@(mapcar 'widget-plist-convert-option
					       options))
			 other)
		 (list other))))
    (widget-put widget :args args)
    widget))

(defun widget-plist-convert-option (option)
  ;; Convert a single plist option.
  (let (key-type value-type)
    (if (listp option)
	(let ((key (nth 0 option)))
	  (setq value-type (nth 1 option))
	  (if (listp key)
	      (setq key-type ,key)
	    (setq key-type `(const ,key))))
      (setq key-type `(const ,option)
	    value-type widget-plist-value-type))
    `(group :format "Key: %v" :inline t ,key-type ,value-type)))


;;; The `alist' Widget.
;;
;; Association lists.

(define-widget 'alist 'list
  "An association list."
  :key-type '(string :tag "Key")
  :value-type '(sexp :tag "Value")
  :convert-widget 'widget-alist-convert-widget
  :tag "Alist")

(defvar widget-alist-value-type)	;Dynamic variable

(defun widget-alist-convert-widget (widget)
  ;; Handle `:options'.
  (let* ((options (widget-get widget :options))
	 (key-type (widget-get widget :key-type))
	 (widget-alist-value-type (widget-get widget :value-type))
	 (other `(editable-list :inline t 
				(cons :format "%v"
				      ,key-type
				      ,widget-alist-value-type)))
	 (args (if options
		   (list `(checklist :inline t
				     :greedy t
				     ,@(mapcar 'widget-alist-convert-option
					       options))
			 other)
		 (list other))))
    (widget-put widget :args args)
    widget))

(defun widget-alist-convert-option (option)
  ;; Convert a single alist option.
  (let (key-type value-type)
    (if (listp option)
	(let ((key (nth 0 option)))
	  (setq value-type (nth 1 option))
	  (if (listp key)
	      (setq key-type ,key)
	    (setq key-type `(const ,key))))
      (setq key-type `(const ,option)
	    value-type widget-alist-value-type))
    `(cons :format "Key: %v" ,key-type ,value-type)))

(define-widget 'choice 'menu-choice
  "A union of several sexp types."
  :tag "Choice"
  :format "%{%t%}: %[Value Menu%] %v"
  :button-prefix 'widget-push-button-prefix

			 (cdr (assoc val choices)))
		     nil)))))
    (if current
	(widget-prompt-value current prompt nil t)
      value)))

(define-widget 'radio 'radio-button-choice
  "A union of several sexp types."
  :tag "Choice"
  :format "%{%t%}:\n%v"
  :prompt-value 'widget-choice-prompt-value)

  :off "off (nil)")

(defun widget-boolean-prompt-value (widget prompt value unbound)
  ;; Toggle a boolean.
  (y-or-n-p prompt))

;;; The `color' Widget.

(define-widget 'color 'editable-field 
  "Choose a color name (with sample)."
  :format "%t: %v (%{sample%})\n"

(defun widget-color-notify (widget child &optional event)
  "Update the sample, and notofy the parent."
  (overlay-put (widget-get widget :sample-overlay) 
	       'face (widget-apply widget :sample-face-get))
  (widget-default-notify widget child event))

;;; The Help Echo

(defun widget-echo-help-mouse ()
  "Display the help message for the widget under the mouse.
Enable with (run-with-idle-timer 1 t 'widget-echo-help-mouse)"