bug#45829: 28.0.50; Some tweaks to the color widget, from wid-edit+.el

bug#45829: 28.0.50; Some tweaks to the color widget, from wid-edit+.el

[Mauro Aranda]

Severity: wishlist

Off-list, Drew offered me to take a look at his additions to
wid-edit.el, in wid-edit+.el [1], to see if some of it would be useful to
add in wid-edit.el itself.

I think the changes to the color widget are useful and straightforward
to bring to the Widget library (there is a FIXME asking for a :match
function for the color widget).

So I put the changes into a patch and gave it a commit message, and I'll
send it as soon as I get a bug number.

[1] https://www.emacswiki.org/emacs/download/wid-edit%2b.el


In GNU Emacs 28.0.50 (build 2, x86_64-pc-linux-gnu, GTK+ Version 3.22.30, cairo version 1.15.10)
 of 2021-01-11 built on tbb-desktop
Repository revision: d8936322f43c88bb1cdebe1a50a7cc7eb0efe834
Repository branch: master
Windowing system distributor 'The X.Org Foundation', version 11.0.12008000
System Description: Ubuntu 18.04.5 LTS

Configured features:
CAIRO DBUS FREETYPE GIF GLIB GMP GNUTLS GSETTINGS HARFBUZZ JPEG
LIBSELINUX LIBXML2 MODULES NOTIFY INOTIFY PDUMPER PNG RSVG SOUND THREADS
TIFF TOOLKIT_SCROLL_BARS X11 XDBE XIM XPM GTK3 ZLIB

Important settings:
  value of $LC_MONETARY: es_AR.UTF-8
  value of $LC_NUMERIC: es_AR.UTF-8
  value of $LC_TIME: es_AR.UTF-8
  value of $LANG: en_US.UTF-8
  locale-coding-system: utf-8-unix

Major mode: ELisp/l

Minor modes in effect:
  shell-dirtrack-mode: t
  bug-reference-prog-mode: t
  global-ede-mode: t
  ede-minor-mode: t
  tooltip-mode: t
  global-eldoc-mode: t
  eldoc-mode: t
  electric-indent-mode: t
  mouse-wheel-mode: t
  tool-bar-mode: t
  menu-bar-mode: t
  file-name-shadow-mode: t
  global-font-lock-mode: t
  font-lock-mode: t
  auto-composition-mode: t
  auto-encryption-mode: t
  auto-compression-mode: t
  column-number-mode: t
  line-number-mode: t
  transient-mark-mode: t

Load-path shadows:
None found.

Features:
(shadow emacsbug sendmail log-edit magit-utils crm dash slime-tests
vc-mtn vc-hg vc-bzr vc-src vc-sccs vc-svn vc-cvs vc-rcs vc-annotate
files-x grep term shell ehelp ert pcase wid-browse vc-dir ewoc mule-util
whitespace ielm add-log log-view pcvs-util cl-print debug backtrace
cus-edit misearch multi-isearch semantic/lex-spp ede/emacs semantic/db
semantic/util-modes semantic/util semantic semantic/tag semantic/lex
semantic/fw mode-local vc-git bug-reference rx org-element avl-tree
ol-eww eww xdg url-queue mm-url ol-rmail ol-mhe ol-irc ol-info ol-gnus
nnselect gnus-search ol-docview doc-view image-mode exif ol-bibtex
bibtex ol-bbdb ol-w3m smerge-mode diff diff-mode jka-compr shr-color
flow-fill mm-archive gnus-fun eieio-opt shortdoc help-fns radix-tree
smiley gnus-cite mail-extr qp gnus-async gnus-bcklg gnus-ml disp-table
cursor-sensor nndraft nnmh nndoc nnfolder cl-extra help-mode gnutls
network-stream nsm gnus-agent gnus-srvr gnus-score score-mode nnvirtual
gnus-msg gnus-art mm-uu mml2015 mm-view mml-smime smime dig nntp
gnus-cache gnus-sum shr kinsoku svg dom gnus-group gnus-undo gnus-start
gnus-dbus gnus-cloud nnimap nnmail mail-source utf7 netrc nnoo
parse-time gnus-spec gnus-int gnus-range message rmc puny rfc822 mml
mml-sec epa epg epg-config mm-decode mm-bodies mm-encode mail-parse
rfc2231 mailabbrev gmm-utils mailheader gnus-win dired-aux ede/dired
edmacro kmacro cus-start cus-load org-capture org-refile
solarized-dark-high-contrast-theme solarized-palettes solarized
solarized-faces color init-ext init-emms dbus emms-librefm-stream
emms-librefm-scrobbler emms-playlist-limit emms-volume
emms-volume-mixerctl emms-volume-pulse emms-volume-amixer emms-i18n
emms-history emms-score emms-stream-info emms-metaplaylist-mode
emms-bookmarks emms-cue emms-mode-line-icon emms-browser sort
emms-playlist-sort emms-last-played emms-player-xine emms-player-mpd tq
emms-playing-time emms-lyrics emms-url emms-streams emms-show-all
emms-tag-editor emms-mark emms-mode-line emms-cache emms-info-exiftool
emms-info-tinytag emms-info-metaflac emms-info-opusinfo
emms-info-ogginfo emms-info-mp3info emms-info emms-later-do
emms-playlist-mode emms-player-vlc emms-player-mpv emms-player-mplayer
emms-player-simple emms-source-playlist emms-source-file locate dired
dired-loaddefs emms-setup emms emms-compat init-gnus gnus nnheader
gnus-util init-org org-clock org ob ob-tangle ob-ref ob-lob ob-table
ob-exp org-macro org-footnote org-src ob-comint org-pcomplete pcomplete
org-list org-faces org-entities org-version ob-emacs-lisp ob-core
ob-eval org-table ol org-keys org-compat advice org-macs org-loaddefs
format-spec find-func cal-menu calendar cal-loaddefs init-social
newsticker newst-treeview tree-widget newst-plainview newst-reader
newst-ticker newst-backend iso8601 time-date xml derived init-cedet
ede/speedbar ede/files ede ede/detect ede/base ede/auto ede/source
eieio-base eieio-speedbar speedbar ezimage dframe eieio-custom wid-edit
cedet init-octave init-rmail undigest rmail rmail-loaddefs rfc2047
rfc2045 ietf-drums mm-util mail-prsvr mail-utils init-vc vc
vc-dispatcher init-cc-mode init-c init-yasnippet init-eshell eshell
esh-cmd esh-ext esh-opt esh-proc esh-io esh-arg esh-module esh-groups
esh-util init-lisp slime compile text-property-search etags fileloop
generator xref project arc-mode archive-mode noutline outline easy-mmode
pp comint ansi-color ring hyperspec thingatpt init-elisp init-global
finder-inf init-package slime-autoloads info package easymenu browse-url
url url-proxy url-privacy url-expand url-methods url-history url-cookie
url-domsuf url-util mailcap url-handlers url-parse auth-source cl-seq
eieio eieio-core cl-macs eieio-loaddefs password-cache json subr-x map
url-vars seq byte-opt gv bytecomp byte-compile cconv cl-loaddefs cl-lib
iso-transl tooltip eldoc electric uniquify ediff-hook vc-hooks
lisp-float-type mwheel term/x-win x-win term/common-win x-dnd tool-bar
dnd fontset image regexp-opt fringe tabulated-list replace newcomment
text-mode elisp-mode lisp-mode prog-mode register page tab-bar menu-bar
rfn-eshadow isearch timer select scroll-bar mouse jit-lock font-lock
syntax facemenu font-core term/tty-colors frame minibuffer cl-generic
cham georgian utf-8-lang misc-lang vietnamese tibetan thai tai-viet lao
korean japanese eucjp-ms cp51932 hebrew greek romanian slovak czech
european ethiopic indian cyrillic chinese composite charscript charprop
case-table epa-hook jka-cmpr-hook help simple abbrev obarray
cl-preloaded nadvice button loaddefs faces cus-face macroexp files
window text-properties overlay sha1 md5 base64 format env code-pages
mule custom widget hashtable-print-readable backquote threads dbusbind
inotify dynamic-setting system-font-setting font-render-setting cairo
move-toolbar gtk x-toolkit x multi-tty make-network-process emacs)

Memory information:
((conses 16 1258345 74841)
 (symbols 48 43820 3)
 (strings 32 179469 4671)
 (string-bytes 1 5243763)
 (vectors 16 75498)
 (vector-slots 8 1608981 191897)
 (floats 8 689 512)
 (intervals 56 81047 1132)
 (buffers 984 54))

bug#45829: 28.0.50; Some tweaks to the color widget, from wid-edit+.el

[Mauro Aranda]

[-- Attachment #1: Type: text/plain, Size: 141 bytes --]

tags 45829 patch
quit

(CCing Drew)

I attach one patch with the changes, and one patch with a test for the
new :match function.

Opinions?


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Patch --]
[-- Type: text/x-patch, Size: 1986 bytes --]

From 8a3a2f8b92708175c62a3b4efd7eb00228c5011a Mon Sep 17 00:00:00 2001
From: Drew Adams <drew.adams@oracle.com>
Date: Tue, 12 Jan 2021 19:14:19 -0300
Subject: [PATCH] Tweaks to the color widget (Bug#45829)

* lisp/wid-edit.el (widget-color-match, widget-color-validate): New
functions.
(color): Use the new functions.  Base size on longest defined color
name.
---
 lisp/wid-edit.el | 18 ++++++++++++++++--
 1 file changed, 16 insertions(+), 2 deletions(-)

diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index 8b10d71dcb..19e58f5345 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -4024,17 +4024,18 @@ widget-boolean-prompt-value
 \f
 ;;; The `color' Widget.
 
-;; Fixme: match
 (define-widget 'color 'editable-field
   "Choose a color name (with sample)."
   :format "%{%t%}: %v (%{sample%})\n"
   :value-create 'widget-color-value-create
-  :size 10
+  :size (1+ (apply #'max (mapcar #'length (defined-colors))))
   :tag "Color"
   :value "black"
   :completions (or facemenu-color-alist (defined-colors))
   :sample-face-get 'widget-color-sample-face-get
   :notify 'widget-color-notify
+  :match #'widget-color-match
+  :validate #'widget-color-validate
   :action 'widget-color-action)
 
 (defun widget-color-value-create (widget)
@@ -4083,6 +4084,19 @@ widget-color-notify
   (overlay-put (widget-get widget :sample-overlay)
 	       'face (widget-apply widget :sample-face-get))
   (widget-default-notify widget child event))
+
+(defun widget-color-match (_widget value)
+  "Non-nil if VALUE is a defined color or a RGB hex string."
+  (and (stringp value)
+       (or (color-defined-p value)
+           (string-match-p "^#\\([[:xdigit:]]\\{3\\}\\)\\{1,4\\}$" value))))
+
+(defun widget-color-validate (widget)
+  "Check that WIDGET's value is a valid color."
+  (let ((value (widget-value widget)))
+    (unless (widget-color-match widget value)
+      (widget-put widget :error (format "Invalid color: %S" value))
+      widget)))
 \f
 ;;; The Help Echo
 
-- 
2.29.2


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: Test --]
[-- Type: text/x-patch, Size: 1282 bytes --]

From 5d6bc24b3b16307361d6411e1b4f1e3735664125 Mon Sep 17 00:00:00 2001
From: Mauro Aranda <maurooaranda@gmail.com>
Date: Tue, 12 Jan 2021 19:19:21 -0300
Subject: [PATCH] Add test for the widget-color-match function (Bug#45829)

* test/lisp/wid-edit-tests.el (widget-test-color-match): New test.
---
 test/lisp/wid-edit-tests.el | 11 +++++++++++
 1 file changed, 11 insertions(+)

diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el
index 17fdfefce8..c410b8e367 100644
--- a/test/lisp/wid-edit-tests.el
+++ b/test/lisp/wid-edit-tests.el
@@ -322,4 +322,15 @@ widget-test-widget-move
     (widget-backward 1)
     (should (string= "Second" (widget-value (widget-at))))))
 
+(ert-deftest widget-test-color-match ()
+  "Test that the :match function for the color widget works."
+  (let* ((widget (widget-convert 'color)))
+    (should (widget-apply widget :match "red"))
+    (should (widget-apply widget :match "#fa3"))
+    (should (widget-apply widget :match "#ff0000"))
+    (should (widget-apply widget :match "#111222333"))
+    (should (widget-apply widget :match "#111122223333"))
+    (should-not (widget-apply widget :match "someundefinedcolorihope"))
+    (should-not (widget-apply widget :match "#11223"))))
+
 ;;; wid-edit-tests.el ends here
-- 
2.29.2

bug#45829: 28.0.50; Some tweaks to the color widget, from wid-edit+.el

[Basil L. Contovounesios]

Mauro Aranda <maurooaranda@gmail.com> writes:

> Opinions?

Just some minor nits from me.

> -;; Fixme: match
>  (define-widget 'color 'editable-field
>    "Choose a color name (with sample)."
>    :format "%{%t%}: %v (%{sample%})\n"
>    :value-create 'widget-color-value-create
> -  :size 10
> +  :size (1+ (apply #'max (mapcar #'length (defined-colors))))

Is defined-colors guaranteed to return non-nil?
If not, you need (apply #'max 0 ...).

> +(defun widget-color-match (_widget value)
> +  "Non-nil if VALUE is a defined color or a RGB hex string."
> +  (and (stringp value)
> +       (or (color-defined-p value)
> +           (string-match-p "^#\\([[:xdigit:]]\\{3\\}\\)\\{1,4\\}$" value))))

Shouldn't that be "\\`#[[:xdigit:]]\\{3\\}\\{1,4\\}\\'"
or at least "\\`#\\(?:[[:xdigit:]]\\{3\\}\\)\\{1,4\\}\\'"
(if you want to be explicit)?

> +(ert-deftest widget-test-color-match ()
> +  "Test that the :match function for the color widget works."
> +  (let* ((widget (widget-convert 'color)))

Nit: could also be let.

> +    (should (widget-apply widget :match "red"))
> +    (should (widget-apply widget :match "#fa3"))
> +    (should (widget-apply widget :match "#ff0000"))
> +    (should (widget-apply widget :match "#111222333"))
> +    (should (widget-apply widget :match "#111122223333"))
> +    (should-not (widget-apply widget :match "someundefinedcolorihope"))
> +    (should-not (widget-apply widget :match "#11223"))))

Thanks,

-- 
Basil

bug#45829: 28.0.50; Some tweaks to the color widget, from wid-edit+.el

[Eli Zaretskii]

> From: "Basil L. Contovounesios" <contovob@tcd.ie>
> Date: Fri, 15 Jan 2021 22:22:38 +0000
> Cc: 45829@debbugs.gnu.org
> 
> >  (define-widget 'color 'editable-field
> >    "Choose a color name (with sample)."
> >    :format "%{%t%}: %v (%{sample%})\n"
> >    :value-create 'widget-color-value-create
> > -  :size 10
> > +  :size (1+ (apply #'max (mapcar #'length (defined-colors))))
> 
> Is defined-colors guaranteed to return non-nil?

Not according to its doc string.

bug#45829: 28.0.50; Some tweaks to the color widget, from wid-edit+.el

[Mauro Aranda]

[-- Attachment #1: Type: text/plain, Size: 1813 bytes --]

"Basil L. Contovounesios" <contovob@tcd.ie> writes:

> Mauro Aranda <maurooaranda@gmail.com> writes:
>
>> Opinions?
>
> Just some minor nits from me.

Hi Basil, thanks for taking a look.

>> -;; Fixme: match
>>  (define-widget 'color 'editable-field
>>    "Choose a color name (with sample)."
>>    :format "%{%t%}: %v (%{sample%})\n"
>>    :value-create 'widget-color-value-create
>> -  :size 10
>> +  :size (1+ (apply #'max (mapcar #'length (defined-colors))))
>
> Is defined-colors guaranteed to return non-nil?
> If not, you need (apply #'max 0 ...).

Thanks for catching this one.  I modified it so as to default to 13,
which would be the longest hex string.

>> +(defun widget-color-match (_widget value)
>> +  "Non-nil if VALUE is a defined color or a RGB hex string."
>> +  (and (stringp value)
>> +       (or (color-defined-p value)
>> +           (string-match-p "^#\\([[:xdigit:]]\\{3\\}\\)\\{1,4\\}$" value))))
>
> Shouldn't that be "\\`#[[:xdigit:]]\\{3\\}\\{1,4\\}\\'"
> or at least "\\`#\\(?:[[:xdigit:]]\\{3\\}\\)\\{1,4\\}\\'"
> (if you want to be explicit)?

I prefer the latter.  I kept the ^ and $, though.

>> +(ert-deftest widget-test-color-match ()
>> +  "Test that the :match function for the color widget works."
>> +  (let* ((widget (widget-convert 'color)))
>
> Nit: could also be let.

Ah yes, the let* was just a leftover.

>> +    (should (widget-apply widget :match "red"))
>> +    (should (widget-apply widget :match "#fa3"))
>> +    (should (widget-apply widget :match "#ff0000"))
>> +    (should (widget-apply widget :match "#111222333"))
>> +    (should (widget-apply widget :match "#111122223333"))
>> +    (should-not (widget-apply widget :match "someundefinedcolorihope"))
>> +    (should-not (widget-apply widget :match "#11223"))))
>
> Thanks,

New patch attached, thanks.


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: Patch --]
[-- Type: text/x-patch, Size: 2080 bytes --]

From be6b966173a9d0d455df884d28efcd6aaa0d54f7 Mon Sep 17 00:00:00 2001
From: Drew Adams <drew.adams@oracle.com>
Date: Sat, 16 Jan 2021 08:56:55 -0300
Subject: [PATCH] Tweaks to the color widget (Bug#45829)

* lisp/wid-edit.el (widget-color-match, widget-color-validate): New
functions.
(color): Use the new functions.  Base size on longest defined color
name, defaulting to the longest RGB hex string.
---
 lisp/wid-edit.el | 19 +++++++++++++++++--
 1 file changed, 17 insertions(+), 2 deletions(-)

diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index 7dda04eda2..68a0d3d235 100644
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -4026,17 +4026,19 @@ widget-boolean-prompt-value
 \f
 ;;; The `color' Widget.
 
-;; Fixme: match
 (define-widget 'color 'editable-field
   "Choose a color name (with sample)."
   :format "%{%t%}: %v (%{sample%})\n"
   :value-create 'widget-color-value-create
-  :size 10
+  :size (1+ (apply #'max 13 ; Longest RGB hex string.
+                   (mapcar #'length (defined-colors))))
   :tag "Color"
   :value "black"
   :completions (or facemenu-color-alist (defined-colors))
   :sample-face-get 'widget-color-sample-face-get
   :notify 'widget-color-notify
+  :match #'widget-color-match
+  :validate #'widget-color-validate
   :action 'widget-color-action)
 
 (defun widget-color-value-create (widget)
@@ -4085,6 +4087,19 @@ widget-color-notify
   (overlay-put (widget-get widget :sample-overlay)
 	       'face (widget-apply widget :sample-face-get))
   (widget-default-notify widget child event))
+
+(defun widget-color-match (_widget value)
+  "Non-nil if VALUE is a defined color or a RGB hex string."
+  (and (stringp value)
+       (or (color-defined-p value)
+           (string-match-p "^#\\(?:[[:xdigit:]]\\{3\\}\\)\\{1,4\\}$" value))))
+
+(defun widget-color-validate (widget)
+  "Check that WIDGET's value is a valid color."
+  (let ((value (widget-value widget)))
+    (unless (widget-color-match widget value)
+      (widget-put widget :error (format "Invalid color: %S" value))
+      widget)))
 \f
 ;;; The Help Echo
 
-- 
2.29.2


[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #3: Patch2 --]
[-- Type: text/x-patch, Size: 1281 bytes --]

From 19efd50021fd5e415305bd367d7fbf6a001db987 Mon Sep 17 00:00:00 2001
From: Mauro Aranda <maurooaranda@gmail.com>
Date: Tue, 12 Jan 2021 19:19:21 -0300
Subject: [PATCH] Add test for the widget-color-match function (Bug#45829)

* test/lisp/wid-edit-tests.el (widget-test-color-match): New test.
---
 test/lisp/wid-edit-tests.el | 11 +++++++++++
 1 file changed, 11 insertions(+)

diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el
index 17fdfefce8..f843649784 100644
--- a/test/lisp/wid-edit-tests.el
+++ b/test/lisp/wid-edit-tests.el
@@ -322,4 +322,15 @@ widget-test-widget-move
     (widget-backward 1)
     (should (string= "Second" (widget-value (widget-at))))))
 
+(ert-deftest widget-test-color-match ()
+  "Test that the :match function for the color widget works."
+  (let ((widget (widget-convert 'color)))
+    (should (widget-apply widget :match "red"))
+    (should (widget-apply widget :match "#fa3"))
+    (should (widget-apply widget :match "#ff0000"))
+    (should (widget-apply widget :match "#111222333"))
+    (should (widget-apply widget :match "#111122223333"))
+    (should-not (widget-apply widget :match "someundefinedcolorihope"))
+    (should-not (widget-apply widget :match "#11223"))))
+
 ;;; wid-edit-tests.el ends here
-- 
2.29.2

bug#45829: 28.0.50; Some tweaks to the color widget, from wid-edit+.el

[Lars Ingebrigtsen]

Mauro Aranda <maurooaranda@gmail.com> writes:

> * lisp/wid-edit.el (widget-color-match, widget-color-validate): New
> functions.
> (color): Use the new functions.  Base size on longest defined color
> name, defaulting to the longest RGB hex string.

Looks good to me (without actually testing the code).

-- 
(domestic pets only, the antidote for overdose, milk.)
   bloggy blog: http://lars.ingebrigtsen.no

bug#45829: 28.0.50; Some tweaks to the color widget, from wid-edit+.el

[Mauro Aranda]

tags 45829 fixed
close 45829
quit


Lars Ingebrigtsen <larsi@gnus.org> writes:> Mauro Aranda <maurooaranda@gmail.com> writes:
>
>> * lisp/wid-edit.el (widget-color-match, widget-color-validate): New
>> functions.
>> (color): Use the new functions.  Base size on longest defined color
>> name, defaulting to the longest RGB hex string.
>
> Looks good to me (without actually testing the code).

Thanks; pushed and closing.