Creating recursive customization types / widgets

[Per Abrahamsen]

Creating new widgets from existing customization type specifications
has something of a black magic feel to it, and creating widgets for
recursive datastructures is next to impossible.

Below is a new widget named "child", which should simplify both tasks
a lot.  

Background: The predefined complex widgets, i.e. the widgets that is
build from other widgets, has their types expanded at creation for
speed.  This obviously goes wrong for recursive types.  This new
"child" widget is a delayed action wrapper of an arbitrary widget,
specified in its :type argument.  The value of the :type argument will
not be expanded before it is needed, which allow for recursive
datastructures.  Since the :type argument to this widget takes exactly
the same values as the :type argument to defcustom, it will also be
useful for people who want to "name" a type for custom use.

If the datastructures is recursive, you need to gave a :match argument
as well as :type.  If not, it will simply match any values that the
type specified for :type will match.

Here is the code for the "child" widget, as well as an example of a
recursive datastructure (a binary tree of strings).  

I suggest we add the "child" widget to wid-edit.el, and document it
somewhere. 

(define-widget 'child 'default
  "Base widget for recursive datastructures.

You need to set :type to the widget type for the datastructure you
want to define, and set :match to a function that matches the
datastructure.  If the datastructure is not recursive, you don't have
to set :match."
  :format "%v"
  ;; We don't convert :type because we want to allow recursive
  ;; datastructures.  This is slow, so we should not create speed
  ;; critical widgets by deriving from this. 
  :convert-widget 'widget-value-convert-widget
  :value-create 'widget-child-value-create
  :value-delete 'widget-children-value-delete
  :value-get 'widget-child-value-get
  :value-inline 'widget-child-value-inline
  :default-get 'widget-child-default-get
  :validate 'widget-child-validate)

(defun widget-child-value-create (widget)
  "Create the child widget."
  (let ((value (widget-get widget :value))
        (type (widget-get widget :type)))
    (widget-put widget :children 
                (list (widget-create-child-value widget 
                                                 (widget-convert type)
                                                 value)))))

(defun widget-child-value-get (widget)
  ;; Get value of the child widget.
  (widget-value (car (widget-get widget :children))))

(defun widget-child-value-inline (widget)
  ;; Get value of the child widget.
  (widget-apply (car (widget-get widget :children)) :value-inline))

(defun widget-child-default-get (widget)
  ;; Get default for the child.
  (widget-default-get (car (widget-get widget :args))))

(defun widget-child-match (widget value)
  "Matches iff the child matches.
You need to overwrite you want to match recursive datastructures."
  (widget-apply (widget-convert (widget-get widget :type)) :match value))

(defun widget-child-validate (widget)
  "Valid iff the child is valid."
  (widget-apply (car (widget-get widget :children)) :validate))


(define-widget 'binary-tree-of-string 'child
  "A binary tree made of cons-cells and strings."
  :offset 4
  :match (lambda (widget value)
           (binary-tree-of-string-p value))
  :type '(menu-choice (string :tag "Leaf" :value "")
                      (cons :tag "Interior"
                            :value ("" . "") 
                            binary-tree-of-string
                            binary-tree-of-string)))

(defun binary-tree-of-string-p (object)
  "Return t if OBJECT is a binary tree of strings."
  (or (stringp object)
      (and (consp object)
           (binary-tree-of-string-p (car object))
           (binary-tree-of-string-p (cdr object)))))

;; Evaluate this to edit the buffer again.
(lisp-interaction-mode)

;; Evaluate this to get the current value.
(widget-value w)

;; Evaluate this to create and edit a test widget.
(progn 
  (setq w (widget-create 'binary-tree-of-string '("a" . (("b" . "c") . "d"))))
  (widget-setup) (widget-browse-mode))