comparison lisp/cus-edit.el @ 18067:0e2aa3b58e16

Synched with version 1.9901.

18066:eecd891e2b63

;;
;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Keywords: help, faces
;; Version: 1.9900
;; 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

(defcustom custom-buffer-sort-predicate 'custom-buffer-sort-alphabetically
  "Function used for sorting group members in buffers.
The value should be useful as a predicate for `sort'.  
The list to be sorted is the value of the groups `custom-group' property."
  :type '(radio (function-item 'custom-buffer-sort-alphabetically)
		(function :tag "Other"))
  :group 'customize)

(defun custom-buffer-sort-alphabetically (a b)
  "Return t iff is A should be before B.

(defcustom custom-menu-sort-predicate 'custom-menu-sort-alphabetically
  "Function used for sorting group members in menus.
The value should be useful as a predicate for `sort'.  
The list to be sorted is the value of the groups `custom-group' property."
  :type '(radio (function-item 'custom-menu-sort-alphabetically)
		(function :tag "Other"))
  :group 'customize)

(defun custom-menu-sort-alphabetically (a b)
  "Return t iff is A should be before B.

(defconst custom-magic-alist '((nil "#" underline "\
uninitialized, you should not see this.")
			       (unknown "?" italic "\
unknown, you should not see this.")
			       (hidden "-" default "\
hidden, invoke the state button to show." "\
group now hidden, invoke the state button to show contents.")
			       (invalid "x" custom-invalid-face "\
the value displayed for this item is invalid and cannot be set.")
			       (modified "*" custom-modified-face "\
you have edited the item, and can now set it." "\
you have edited something in this group, and can now set it.")

left out, ITEM-DESC will be used.

The list should be sorted most significant first.")

(defcustom custom-magic-show 'long
  "Show long description of the state of each customization option."
  :type '(choice (const :tag "no" nil)
		 (const short)
		 (const long))
  :group 'customize)

(defcustom custom-magic-show-button nil
  "Show a magic button indicating the state of each customization option."
  :type 'boolean

(defun custom-magic-value-create (widget)
  ;; Create compact status report for WIDGET.
  (let* ((parent (widget-get widget :parent))
	 (state (widget-get parent :custom-state))
	 (entry (assq state custom-magic-alist))
	 (magic (nth 1 entry))
	 (face (nth 2 entry))
	 (text (or (and (eq (widget-type parent) 'custom-group)
			(nth 4 entry))
		   (nth 3 entry)))
	 (lisp (eq (widget-get parent :custom-form) 'lisp))
	 children)
    (when custom-magic-show
      (insert "   ")
      (push (widget-create-child-and-convert 
	     widget 'choice-item 
	     :help-echo "\
Change the state of this item."
	     :format "%[%t%]"
	     :button-prefix 'widget-push-button-prefix
	     :button-suffix 'widget-push-button-suffix
	     :mouse-down-action 'widget-magic-mouse-down-action
	     :tag "State")
	    children)

	    (insert-char ?  indent))))
      (push (widget-create-child-and-convert 
	     widget 'choice-item 
	     :mouse-down-action 'widget-magic-mouse-down-action
	     :button-face face
	     :help-echo "Change the state."
	     :format "%[%t%]"
	     :tag (if lisp 
		      (concat "(" magic ")")
		    (concat "[" magic "]")))
	    children)
      (insert " "))

  (let* ((buttons (widget-get widget :buttons))
	 (state (widget-get widget :custom-state))
	 (level (widget-get widget :custom-level)))
    (cond ((eq escape ?l)
	   (when level 
	     (push (widget-create-child-and-convert
		    widget 'item :format "%v " (make-string level ?*))
		   buttons)
	     (widget-put widget :buttons buttons)))
	  ((eq escape ?L)
	   (when (eq state 'hidden)
	     (widget-insert " ...")))
	  ((eq escape ?m)
	   (and (eq (preceding-char) ?\n)
		(widget-get widget :indent)
		(insert-char ?  (widget-get widget :indent)))
	   (let ((magic (widget-create-child-and-convert
			 widget 'custom-magic nil)))
	     (widget-put widget :custom-magic magic)
	     (push magic buttons)
	     (widget-put widget :buttons buttons)))
	  ((eq escape ?a)
	   (let* ((symbol (widget-get widget :value))
		  (links (get symbol 'custom-links))
		  (many (> (length links) 2)))
	     (when links
	       (and (eq (preceding-char) ?\n)
		    (widget-get widget :indent)
		    (insert-char ?  (widget-get widget :indent)))
	       (insert "See also ")
	       (while links
		 (push (widget-create-child-and-convert widget (car links))
		       buttons)
		 (setq links (cdr links))
		 (cond ((null links)
			(insert ".\n"))
		       ((null (cdr links))
			(if many
			    (insert ", and ")
			  (insert " and ")))
		       (t 
			(insert ", "))))
	       (widget-put widget :buttons buttons))))
	  (t 
	   (widget-default-format-handler widget escape)))))

(defun custom-notify (widget &rest args)
  "Keep track of changes."

    (cond ((memq state '(invalid modified))
	   (error "There are unset changes"))
	  ((eq state 'hidden)
	   (widget-put widget :custom-state 'unknown))
	  (t 
	   (widget-put widget :custom-state 'hidden)))
    (custom-redraw widget)))

;;; The `custom-variable' Widget.

(defface custom-variable-sample-face '((t (:underline t)))
  "Face used for unpushable variable tags."

    ;; Now we can create the child widget.
    (cond ((eq state 'hidden)
	   ;; Indicate hidden value.
	   (push (widget-create-child-and-convert 
		  widget 'item
		  :format "%{%t%}: ..."
		  :sample-face 'custom-variable-sample-face
		  :tag tag
		  :parent widget)
		 children))
	  ((eq form 'lisp)
	   ;; In lisp mode edit the saved value when possible.
	   (let* ((value (cond ((get symbol 'saved-value)
				(car (get symbol 'saved-value)))
			       ((get symbol 'standard-value)
				(car (get symbol 'standard-value)))
			       ((default-boundp symbol)
				(custom-quote (funcall get symbol)))
			       (t
				(custom-quote (widget-get conv :value))))))
	     (push (widget-create-child-and-convert 
		    widget 'sexp 
		    :button-face 'custom-variable-button-face
		    :tag (symbol-name symbol)
		    :parent widget
		    :value value)
		   children)))
	  (t
	   ;; Edit mode.
	   (push (widget-create-child-and-convert
		  widget type 
		  :tag tag
		  :button-face 'custom-variable-button-face
		  :sample-face 'custom-variable-sample-face
		  :value value)
		 children)))
    ;; Now update the state.
    (unless (eq (preceding-char) ?\n)
      (widget-insert "\n"))
    (if (eq state 'hidden)
	(widget-put widget :custom-state state)
      (custom-variable-state-set widget))
    (widget-put widget :custom-form form)	     
    (widget-put widget :buttons buttons)
    (widget-put widget :children children)))

(defun custom-variable-state-set (widget)
  "Set the state of WIDGET."
  (let* ((symbol (widget-value widget))
	 (get (or (get symbol 'custom-get) 'default-value))

			 'changed))
		      (t 'rogue))))
    (widget-put widget :custom-state state)))

(defvar custom-variable-menu 
  '(("Hide" custom-toggle-hide
     (lambda (widget)
       (not (memq (widget-get widget :custom-state) '(modified invalid)))))
     ("Edit" custom-variable-edit 
     (lambda (widget)
       (not (eq (widget-get widget :custom-form) 'edit))))
    ("Edit Lisp" custom-variable-edit-lisp
     (lambda (widget)
       (not (eq (widget-get widget :custom-form) 'lisp))))

  "Face used for face tags."
  :group 'custom-faces)

(define-widget 'custom-face 'custom
  "Customize face."
  :format "%{%t%}: %s%m%h%a%v"
  :format-handler 'custom-face-format-handler
  :sample-face 'custom-face-tag-face
  :help-echo "Set or reset this face."
  :documentation-property '(lambda (face)
			     (face-doc-string face))

		;; XEmacs cannot display initialized faces.
		(not (custom-facep symbol))
		(copy-face 'custom-face-empty symbol))
	   (setq child (widget-create-child-and-convert 
			widget 'item
			:format "(%{%t%})\n"
			:sample-face symbol
			:tag "sample")))
	  (t 
	   (custom-format-handler widget escape)))
    (when child

      (custom-face-state-set widget)
      (widget-put widget :children (list edit)))
    (message "Creating face editor...done")))

(defvar custom-face-menu 
  '(("Hide" custom-toggle-hide
     (lambda (widget)
       (not (memq (widget-get widget :custom-state) '(modified invalid)))))
    ("Edit Selected" custom-face-edit-selected
     (lambda (widget)
       (not (eq (widget-get widget :custom-form) 'selected))))
    ("Edit All" custom-face-edit-all
     (lambda (widget)
       (not (eq (widget-get widget :custom-form) 'all))))

(defun widget-face-value-create (widget)
  ;; Create a `custom-face' child.
  (let* ((symbol (widget-value widget))
	 (child (widget-create-child-and-convert
		 widget 'custom-face
		 :format "%t %s%m%h%v"
		 :custom-level nil
		 :value symbol)))
    (custom-magic-reset child)
    (setq custom-options (cons child custom-options))
    (widget-put widget :children (list child))))

  "Face used for low level group tags."
  :group 'custom-faces)

(define-widget 'custom-group 'custom
  "Customize group."
  :format "%l%{%t%}:%L\n%m%h%a%v"
  :sample-face-get 'custom-group-sample-face-get
  :documentation-property 'group-documentation
  :help-echo "Set or reset all members of this group."
  :value-create 'custom-group-value-create
  :action 'custom-group-action

	(widget-put widget :children children)
	(custom-group-state-update widget)
	(message "Creating group... done")))))

(defvar custom-group-menu 
  '(("Hide" custom-toggle-hide
     (lambda (widget)
       (not (memq (widget-get widget :custom-state) '(modified invalid)))))
    ("Set" custom-group-set
     (lambda (widget)
       (eq (widget-get widget :custom-state) 'modified)))
    ("Save" custom-group-save
     (lambda (widget)
       (memq (widget-get widget :custom-state) '(modified set))))

18067:0e2aa3b58e16

;;
;; Copyright (C) 1996, 1997 Free Software Foundation, Inc.
;;
;; Author: Per Abrahamsen <[e-mail]>
;; Keywords: help, faces
;; Version: 1.9901
;; 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

(defcustom custom-buffer-sort-predicate 'custom-buffer-sort-alphabetically
  "Function used for sorting group members in buffers.
The value should be useful as a predicate for `sort'.  
The list to be sorted is the value of the groups `custom-group' property."
  :type '(radio (function-item custom-buffer-sort-alphabetically)
		(function :tag "Other"))
  :group 'customize)

(defun custom-buffer-sort-alphabetically (a b)
  "Return t iff is A should be before B.

(defcustom custom-menu-sort-predicate 'custom-menu-sort-alphabetically
  "Function used for sorting group members in menus.
The value should be useful as a predicate for `sort'.  
The list to be sorted is the value of the groups `custom-group' property."
  :type '(radio (function-item custom-menu-sort-alphabetically)
		(function :tag "Other"))
  :group 'customize)

(defun custom-menu-sort-alphabetically (a b)
  "Return t iff is A should be before B.

(defconst custom-magic-alist '((nil "#" underline "\
uninitialized, you should not see this.")
			       (unknown "?" italic "\
unknown, you should not see this.")
			       (hidden "-" default "\
hidden, invoke the dots above to show." "\
group now hidden, invoke the dots above to show contents.")
			       (invalid "x" custom-invalid-face "\
the value displayed for this item is invalid and cannot be set.")
			       (modified "*" custom-modified-face "\
you have edited the item, and can now set it." "\
you have edited something in this group, and can now set it.")

left out, ITEM-DESC will be used.

The list should be sorted most significant first.")

(defcustom custom-magic-show 'long
  "If non-nil, show textual description of the state.
If non-nil and not the symbol `long', only show first word."
  :type '(choice (const :tag "no" nil)
		 (const short)
		 (const long))
  :group 'customize)

(defcustom custom-magic-show-hidden nil
  "If non-nil, also show long state description of hidden options."
  :type 'boolean
  :group 'customize)

(defcustom custom-magic-show-button nil
  "Show a magic button indicating the state of each customization option."
  :type 'boolean

(defun custom-magic-value-create (widget)
  ;; Create compact status report for WIDGET.
  (let* ((parent (widget-get widget :parent))
	 (state (widget-get parent :custom-state))
	 (hidden (eq state 'hidden))
	 (entry (assq state custom-magic-alist))
	 (magic (nth 1 entry))
	 (face (nth 2 entry))
	 (text (or (and (eq (widget-type parent) 'custom-group)
			(nth 4 entry))
		   (nth 3 entry)))
	 (lisp (eq (widget-get parent :custom-form) 'lisp))
	 children)
    (when (and custom-magic-show
	       (or custom-magic-show-hidden (not hidden)))
      (insert "   ")
      (push (widget-create-child-and-convert 
	     widget 'choice-item 
	     :help-echo "\
Change the state of this item."
	     :format (if hidden "%t" "%[%t%]")
	     :button-prefix 'widget-push-button-prefix
	     :button-suffix 'widget-push-button-suffix
	     :mouse-down-action 'widget-magic-mouse-down-action
	     :tag "State")
	    children)

	    (insert-char ?  indent))))
      (push (widget-create-child-and-convert 
	     widget 'choice-item 
	     :mouse-down-action 'widget-magic-mouse-down-action
	     :button-face face
	     :button-prefix ""
	     :button-suffix ""
	     :help-echo "Change the state."
	     :format (if hidden "%t" "%[%t%]")
	     :tag (if lisp 
		      (concat "(" magic ")")
		    (concat "[" magic "]")))
	    children)
      (insert " "))

  (let* ((buttons (widget-get widget :buttons))
	 (state (widget-get widget :custom-state))
	 (level (widget-get widget :custom-level)))
    (cond ((eq escape ?l)
	   (when level 
	     (if (eq state 'hidden)
		 (insert-char ?- (* 2 level))
	       (insert "/" (make-string (1- (* 2 level)) ?-)))))
	  ((eq escape ?e)
	   (when (and level (not (eq state 'hidden)))
	     (insert "\n\\" (make-string (1- (* 2 level)) ?-) " "
		     (widget-get widget :tag) " group end ")
	     (insert (make-string (- 75 (current-column)) ?-) "/\n")))
	  ((eq escape ?-)
	   (when level 
	     (if (eq state 'hidden)
		 (insert-char ?- (- 77 (current-column)))		 
	       (insert (make-string (- 76 (current-column)) ?-) "\\"))))
	  ((eq escape ?L)
	   (push (widget-create-child-and-convert
		  widget 'visibility
		  :action 'custom-toggle-parent
		  (not (eq state 'hidden)))
		 buttons))
	  ((eq escape ?m)
	   (and (eq (preceding-char) ?\n)
		(widget-get widget :indent)
		(insert-char ?  (widget-get widget :indent)))
	   (let ((magic (widget-create-child-and-convert
			 widget 'custom-magic nil)))
	     (widget-put widget :custom-magic magic)
	     (push magic buttons)
	     (widget-put widget :buttons buttons)))
	  ((eq escape ?a)
	   (unless (eq state 'hidden)
	     (let* ((symbol (widget-get widget :value))
		    (links (get symbol 'custom-links))
		    (many (> (length links) 2)))
	       (when links
		 (and (eq (preceding-char) ?\n)
		      (widget-get widget :indent)
		      (insert-char ?  (widget-get widget :indent)))
		 (insert "See also ")
		 (while links
		   (push (widget-create-child-and-convert widget (car links))
			 buttons)
		   (setq links (cdr links))
		   (cond ((null links)
			  (insert ".\n"))
			 ((null (cdr links))
			  (if many
			      (insert ", and ")
			    (insert " and ")))
			 (t 
			  (insert ", "))))
		 (widget-put widget :buttons buttons)))))
	  (t 
	   (widget-default-format-handler widget escape)))))

(defun custom-notify (widget &rest args)
  "Keep track of changes."

    (cond ((memq state '(invalid modified))
	   (error "There are unset changes"))
	  ((eq state 'hidden)
	   (widget-put widget :custom-state 'unknown))
	  (t 
	   (widget-put widget :documentation-shown nil)
	   (widget-put widget :custom-state 'hidden)))
    (custom-redraw widget)))

(defun custom-toggle-parent (widget &rest ignore)
  "Toggle visibility of parent to WIDGET."
  (custom-toggle-hide (widget-get widget :parent)))

;;; The `custom-variable' Widget.

(defface custom-variable-sample-face '((t (:underline t)))
  "Face used for unpushable variable tags."

    ;; Now we can create the child widget.
    (cond ((eq state 'hidden)
	   ;; Indicate hidden value.
	   (push (widget-create-child-and-convert 
		  widget 'item
		  :format "%{%t%}: "
		  :sample-face 'custom-variable-sample-face
		  :tag tag
		  :parent widget)
		 buttons)
	   (push (widget-create-child-and-convert 
		  widget 'visibility
		  :action 'custom-toggle-parent
		  nil)
		 buttons))
	  ((eq form 'lisp)
	   ;; In lisp mode edit the saved value when possible.
	   (let* ((value (cond ((get symbol 'saved-value)
				(car (get symbol 'saved-value)))
			       ((get symbol 'standard-value)
				(car (get symbol 'standard-value)))
			       ((default-boundp symbol)
				(custom-quote (funcall get symbol)))
			       (t
				(custom-quote (widget-get conv :value))))))
	     (insert (symbol-name symbol) ": ")
	     (push (widget-create-child-and-convert 
		  widget 'visibility
		  :action 'custom-toggle-parent
		  t)
		 buttons)
	     (insert " ")
	     (push (widget-create-child-and-convert 
		    widget 'sexp 
		    :button-face 'custom-variable-button-face
		    :format "%v"
		    :tag (symbol-name symbol)
		    :parent widget
		    :value value)
		   children)))
	  (t
	   ;; Edit mode.
	   (let* ((format (widget-get type :format))
		  tag-format value-format)
	     (unless (string-match ":" format)
	       (error "Bad format."))
	     (setq tag-format (substring format 0 (match-end 0)))
	     (setq value-format (substring format (match-end 0)))
	     (push (widget-create-child-and-convert
		    widget 'item 
		    :format tag-format
		    :action 'custom-tag-action
		    :mouse-down-action 'custom-tag-mouse-down-action
		    :button-face 'custom-variable-button-face
		    :sample-face 'custom-variable-sample-face
		    tag)
		   buttons)
	     (insert " ")
	     (push (widget-create-child-and-convert 
		  widget 'visibility
		  :action 'custom-toggle-parent
		  t)
		 buttons)	     
	     (push (widget-create-child-and-convert
		    widget type 
		    :format value-format
		    :value value)
		   children))))
    ;; Now update the state.
    (unless (eq (preceding-char) ?\n)
      (widget-insert "\n"))
    (if (eq state 'hidden)
	(widget-put widget :custom-state state)
      (custom-variable-state-set widget))
    (widget-put widget :custom-form form)	     
    (widget-put widget :buttons buttons)
    (widget-put widget :children children)))

(defun custom-tag-action (widget &rest args)
  "Pass :action to first child of WIDGET's parent."
  (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
	 :action args))

(defun custom-tag-mouse-down-action (widget &rest args)
  "Pass :mouse-down-action to first child of WIDGET's parent."
  (apply 'widget-apply (car (widget-get (widget-get widget :parent) :children))
	 :mouse-down-action args))

(defun custom-variable-state-set (widget)
  "Set the state of WIDGET."
  (let* ((symbol (widget-value widget))
	 (get (or (get symbol 'custom-get) 'default-value))

			 'changed))
		      (t 'rogue))))
    (widget-put widget :custom-state state)))

(defvar custom-variable-menu 
  '(("Edit" custom-variable-edit 
     (lambda (widget)
       (not (eq (widget-get widget :custom-form) 'edit))))
    ("Edit Lisp" custom-variable-edit-lisp
     (lambda (widget)
       (not (eq (widget-get widget :custom-form) 'lisp))))

  "Face used for face tags."
  :group 'custom-faces)

(define-widget 'custom-face 'custom
  "Customize face."
  :format "%{%t%}: %s %L\n%m%h%a%v"
  :format-handler 'custom-face-format-handler
  :sample-face 'custom-face-tag-face
  :help-echo "Set or reset this face."
  :documentation-property '(lambda (face)
			     (face-doc-string face))

		;; XEmacs cannot display initialized faces.
		(not (custom-facep symbol))
		(copy-face 'custom-face-empty symbol))
	   (setq child (widget-create-child-and-convert 
			widget 'item
			:format "(%{%t%})"
			:sample-face symbol
			:tag "sample")))
	  (t 
	   (custom-format-handler widget escape)))
    (when child

      (custom-face-state-set widget)
      (widget-put widget :children (list edit)))
    (message "Creating face editor...done")))

(defvar custom-face-menu 
  '(("Edit Selected" custom-face-edit-selected
     (lambda (widget)
       (not (eq (widget-get widget :custom-form) 'selected))))
    ("Edit All" custom-face-edit-all
     (lambda (widget)
       (not (eq (widget-get widget :custom-form) 'all))))

(defun widget-face-value-create (widget)
  ;; Create a `custom-face' child.
  (let* ((symbol (widget-value widget))
	 (child (widget-create-child-and-convert
		 widget 'custom-face
		 :format "%t %s %L\n%m%h%v"
		 :custom-level nil
		 :value symbol)))
    (custom-magic-reset child)
    (setq custom-options (cons child custom-options))
    (widget-put widget :children (list child))))

  "Face used for low level group tags."
  :group 'custom-faces)

(define-widget 'custom-group 'custom
  "Customize group."
  :format "%l %{%t%} group: %L %-\n%m%h%a%v%e"
  :sample-face-get 'custom-group-sample-face-get
  :documentation-property 'group-documentation
  :help-echo "Set or reset all members of this group."
  :value-create 'custom-group-value-create
  :action 'custom-group-action

	(widget-put widget :children children)
	(custom-group-state-update widget)
	(message "Creating group... done")))))

(defvar custom-group-menu 
  '(("Set" custom-group-set
     (lambda (widget)
       (eq (widget-get widget :custom-state) 'modified)))
    ("Save" custom-group-save
     (lambda (widget)
       (memq (widget-get widget :custom-state) '(modified set))))