Re: custom type `color' is not enforced

[Per Abrahamsen]

>From my unreliable memory:

The :validate function exist to check that the value the user has
entered in the widget actually match the "type" of the widget.  If the
user enter "kurt" in the editable text for an integer widget, validate
will signal an error.

The :match function exist to choose when "branch" to take for a choice
widget, and a few similar situations:  E.g. if you instantiate a
(choice integer string) type with the initial value of "kurt", the
second branch of the choice should be activated.  The logic of the
:match widget can be quite complex with composite wdgets, in fact the
whole mechanism is regular expressions over the "alphabet" of sexps.
Or should have been, had it been done right, the actual implementation
is somewhat weaker.

The :match function takes the widget as an argument, because sometimes
whether or not it matches depends on the widget properties.  For
example, the choice widget above will match strings and integers, but
another choice widget with other arguments will match other values.

-- Per

On 12/22/07, Lennart Borgman (gmail) <address@hidden> wrote:
> Richard Stallman wrote:
> > You have the right idea.
>
> I have tried to finish the code too now ;-)
>
> Please see the attached files. Beside a more complete widget type for
> colors I have also included some basic functions for testing custom
> types. I believe these could be useful.
>
> I have tried to make them as clean and simple as they can be at the
> moment. However I am unsure about how to call the :match and :validate
> functions. I might very well be missing something concerning the
> conversion from and to external values.
>
> BTW when I have been looking at this I have had a hard time to
> understand why there are both :match and :validate functions.
>
> I also do not understand the paramters they take. Why do the :match
> function have a widget parameter? Does it have something to do with
> external - internal conversion, or?
>
>
>
> (defun color-digits-p (color)
>  (save-match-data
>    (string-match (rx bos
>                      "#"
>                      (1+ (repeat 3 3 hex-digit))
>                      eos)
>                  color)))
>
> (defun widget-color-match (widget value)
>  (or
>   ;; I am not sure what colors to test. It might be relevant to check
>   ;; all as I suggest here.
>   ;;(color-defined-p val)
>   (member value x-colors)
>   (and (stringp value)
>        (color-digits-p value))))
>
> (defun widget-color-validate (widget)
>  (let ((value (widget-value widget)))
>    (unless (widget-color-match widget value)
>      (widget-put widget :error (format "Invalid color: %S" value))
>      widget)))
>
> (define-widget 'color 'editable-field
>  "Choose a color (with sample)."
>  :format "%{%t%}: %v (%{sample%})\n"
>  :size 25  ;; (length "light coldenrod yellow") = 22
>  :tag "Color"
>  :match 'widget-color-match
>  :validate 'widget-color-validate
>  :value "black"
>  :complete 'widget-color-complete
>  :sample-face-get 'widget-color-sample-face-get
>  :notify 'widget-color-notify
>  :action 'widget-color-action)
>
> (defun custom-type-symbol-p (symbol custom-type)
>  "Return t if value of symbol SYMBOL should fit CUSTOM-TYPE."
>  (let ((found nil)
>        (type (get symbol 'custom-type)))
>    (while (and (not found) type)
>      (setq found (eq type custom-type))
>      (setq type (car (get type 'widget-type))))
>    found))
>
> (defun custom-type-value-p (value custom-type)
>  "Return non-nil if value of VALUE fits CUSTOM-TYPE."
>  (let ((widget (if (listp custom-type)
>                    custom-type
>                  (list custom-type))))
>    (setq widget (widget-convert widget))
>    ;; There are (unfortunately) two different ways to test the
>    ;; values in a widget. Some widget types use both, some just one
>    ;; of them. We check for both, but only use one of them here.
>    (let ((match-fun (widget-get widget :match))
>          (validate-fun (widget-get widget :validate)))
>      ;;(setq match-fun nil)
>      ;;(setq validate-fun nil)
>      (widget-put widget :value value)
>      ;; Fix-me: I am not sure whether widget-apply of funcall
>      ;; should be used here, but I believe anyone of them can be
>      ;; used. But please look into this. It might have something to
>      ;; do with internal/external values for the widgets.
>      (cond
>       ;; Test the :match alternative first because this because this
>       ;; seems most basic.
>       (match-fun
>        (when
>            ;;(widget-apply widget :match value)
>            (funcall match-fun widget value)
>          t))
>       (validate-fun
>        (let (;;(val (widget-apply widget :validate))
>              (val (funcall validate-fun widget)))
>          ;; Check if :error was applied
>          (when (not (widget-get val :error)) t)))
>       (t
>        (error
>         "There is no way to check value against custom type %s"
>         custom-type))))))
>
> (defun custom-type-p (val-or-sym custom-type)
>  "Return non-nil if VAL-OR-SYM fits CUSTOM-TYPE.
> VAL-OR-SYM may be either a variable or a symbol. If it is a
> variable then return non-nil if the value fits custom type
> CUSTOM-TYPE.
>
> If it is a symbol then return non-nil if the values this symbol's
> variable can have fits CUSTOM-TYPE."
>  (if (symbolp val-or-sym)
>      (custom-type-symbol-p val-or-sym custom-type)
>    (custom-type-value-p val-or-sym custom-type)))
>
> ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
> ;;; Tests
>
> ;; (custom-type-p 'test-color 'color)
> ;; (custom-type-p 'test-color 'edit)
> ;; (custom-type-p 'test-color 'editable-field)
> ;; (custom-type-p test-color 'color)
> ;; (get 'test-color 'custom-type)
> ;; (setq test-color "bla")
> ;; (setq test-color "black")
>
> (defcustom test-color "black"
>  "color test"
>  :type 'color)
>
> (defun max-color-length()
>  (let ((len 0)
>        (longest ""))
>    (mapc (lambda (color)
>            (when (< len (length color))
>              (setq len (length color))
>              (setq longest color)))
>          x-colors)
>    (cons len longest)))
> ;; (max-color-length)
>
>