Fix matching of inline choices for the choice widget

A choice widget should be able to match either no inline values or
inline values, upon request.  (Bug#44579)

* lisp/wid-edit.el (choice): New property, :inline-bubbles-p.  A
predicate that returns non-nil if the choice widget can act as an
inline widget.  Document it.
(widget-choice-inline-bubbles-p): New function, for the
:inline-bubbles-p property of the choice widget.
(widget-inline-p): New function.  Use the :inline-bubbles-p property
of the widget, if any.
(widget-match-inline): Use the above to see if the widget can act like
an inline widget.  Document it.
(widget-choice-value-create): Account for the case of a choice widget
that has inline members.
(widget-checklist-add-item, widget-editable-list-value-create)
(widget-group-value-create): Use widget-inline-p rather than just
checking for a non-nil :inline property, allowing these functions to
pass the complete information to widgets like the choice widget to
create their values.

* test/lisp/wid-edit-tests.el (widget-test-choice-match-no-inline)
(widget-test-choice-match-all-inline)
widget-test-choice-match-some-inline): New tests, to check that choice
widgets can match its choices, inline or not.
(widget-test-inline-p): New test, for the new function
widget-inline-p.
(widget-test-repeat-can-handle-choice)
(widget-test-repeat-can-handle-inlinable-choice)
(widget-test-list-can-handle-choice)
(widget-test-list-can-handle-inlinable-choice)
(widget-test-option-can-handle-choice)
(widget-test-option-can-handle-inlinable-choice): New tests.  This
grouping widgets need to be able to create a choice widget regardless
if it has inline choices or not.

diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el
index 4e2cf7416d48abd6ffc497a5a47a2c792aa88843..8250316bcc7a64a6bb7ed4299351515e348668c5 100644 (file)
--- a/lisp/wid-edit.el
+++ b/lisp/wid-edit.el
@@ -591,9 +591,25 @@ Otherwise, just return the value."
                          (widget-put widget :args args)))
                      (widget-apply widget :default-get)))))
 
+(defun widget-inline-p (widget &optional bubblep)
+  "Non-nil if the widget WIDGET is inline.
+
+With BUBBLEP non-nil, check also if WIDGET has a member that bubbles its inline
+property (if any), up to WIDGET, so that WIDGET can act as an inline widget."
+  (or (widget-get widget :inline)
+      (and bubblep
+           (widget-get widget :inline-bubbles-p)
+           (widget-apply widget :inline-bubbles-p))))
+
 (defun widget-match-inline (widget vals)
-  "In WIDGET, match the start of VALS."
-  (cond ((widget-get widget :inline)
+  "In WIDGET, match the start of VALS.
+
+For an inline widget or for a widget that acts like one (see `widget-inline-p'),
+try to match elements in VALS as far as possible.  Otherwise, match the first
+element of the list VALS.
+
+Return a list whose car contains all members of VALS that matched WIDGET."
+  (cond ((widget-inline-p widget t)
         (widget-apply widget :match-inline vals))
        ((and (listp vals)
              (widget-apply widget :match (car vals)))
@@ -2198,7 +2214,7 @@ But if NO-TRUNCATE is non-nil, include them."
   (let ((value (widget-get widget :value))
        (args (widget-get widget :args))
        (explicit (widget-get widget :explicit-choice))
-       current)
+        current val inline-p fun)
     (if explicit
        (progn
          ;; If the user specified the choice for this value,
@@ -2207,15 +2223,24 @@ But if NO-TRUNCATE is non-nil, include them."
                                              widget explicit value)))
          (widget-put widget :choice explicit)
          (widget-put widget :explicit-choice nil))
+      (setq inline-p (widget-inline-p widget t))
       (while args
        (setq current (car args)
              args (cdr args))
-       (when (widget-apply current :match value)
-         (widget-put widget :children (list (widget-create-child-value
-                                             widget current value)))
-         (widget-put widget :choice current)
-         (setq args nil
-               current nil)))
+        (if inline-p
+            (if (widget-get current :inline)
+                (setq val value
+                      fun :match-inline)
+              (setq val (car value)
+                    fun :match))
+          (setq val value
+                fun :match))
+        (when (widget-apply current fun val)
+          (widget-put widget :children (list (widget-create-child-value
+                                              widget current val)))
+          (widget-put widget :choice current)
+          (setq args nil
+                current nil)))
       (when current
        (let ((void (widget-get widget :void)))
          (widget-put widget :children (list (widget-create-child-and-convert
@@ -2438,7 +2463,7 @@ If the item is checked, CHOSEN is a cons whose cdr is the value."
                             (let ((child (widget-create-child widget type)))
                               (widget-apply child :deactivate)
                               child))
-                           ((widget-get type :inline)
+                            ((widget-inline-p type t)
                             (widget-create-child-value
                              widget type (cdr chosen)))
                            (t
@@ -2795,7 +2820,7 @@ Return an alist of (TYPE MATCH)."
        (if answer
            (setq children (cons (widget-editable-list-entry-create
                                  widget
-                                 (if (widget-get type :inline)
+                                  (if (widget-inline-p type t)
                                      (car answer)
                                    (car (car answer)))
                                  t)
@@ -2979,7 +3004,7 @@ Save CHILD into the :last-deleted list, so it can be inserted later."
           (insert-char ?\s (widget-get widget :indent)))
       (push (cond ((null answer)
                   (widget-create-child widget arg))
-                 ((widget-get arg :inline)
+                  ((widget-inline-p arg t)
                   (widget-create-child-value widget arg (car answer)))
                  (t
                   (widget-create-child-value widget arg (car (car answer)))))
@@ -3900,12 +3925,17 @@ example:
     `(cons :format "Key: %v" ,key-type ,value-type)))
 \f
 (define-widget 'choice 'menu-choice
-  "A union of several sexp types."
+  "A union of several sexp types.
+
+If one of the choices of a choice widget has an :inline t property,
+then the choice widget can act as an inline widget on its own if the
+current choice is inline."
   :tag "Choice"
   :format "%{%t%}: %[Value Menu%] %v"
   :button-prefix 'widget-push-button-prefix
   :button-suffix 'widget-push-button-suffix
-  :prompt-value 'widget-choice-prompt-value)
+  :prompt-value 'widget-choice-prompt-value
+  :inline-bubbles-p #'widget-choice-inline-bubbles-p)
 
 (defun widget-choice-prompt-value (widget prompt value _unbound)
   "Make a choice."
@@ -3948,6 +3978,20 @@ example:
     (if current
        (widget-prompt-value current prompt nil t)
       value)))
+
+(defun widget-choice-inline-bubbles-p (widget)
+  "Non-nil if the choice WIDGET has at least one choice that is inline.
+This is used when matching values, because a choice widget needs to
+match a value inline rather than just match it if at least one of its choices
+is inline."
+  (let ((args (widget-get widget :args))
+        cur found)
+    (while (and args (not found))
+      (setq cur (car args)
+            args (cdr args)
+            found (widget-get cur :inline)))
+    found))
+
 \f
 (define-widget 'radio 'radio-button-choice
   "A union of several sexp types."

diff --git a/test/lisp/wid-edit-tests.el b/test/lisp/wid-edit-tests.el
index 4508b680232cd0546f8b44348fc45129c33b3a85..1bd429736ea99e2e5953ac12d702ae014ec6f4d4 100644 (file)
--- a/test/lisp/wid-edit-tests.el
+++ b/test/lisp/wid-edit-tests.el
@@ -148,4 +148,157 @@
       ;; Check that we effectively moved the item to the last position.
       (should (equal (widget-value lst) '("beg" "middle" "end"))))))
 
+(ert-deftest widget-test-choice-match-no-inline ()
+  "Test that a no-inline choice widget can match its values."
+  (let* ((choice '(choice (const nil) (const t) string function))
+         (widget (widget-convert choice)))
+    (should (widget-apply widget :match nil))
+    (should (widget-apply widget :match t))
+    (should (widget-apply widget :match ""))
+    (should (widget-apply widget :match 'ignore))))
+
+(ert-deftest widget-test-choice-match-all-inline ()
+  "Test that a choice widget with all inline members can match its values."
+  (let* ((lst '(list (choice (list :inline t symbol number)
+                             (list :inline t symbol regexp))))
+         (widget (widget-convert lst)))
+    (should-not (widget-apply widget :match nil))
+    (should (widget-apply widget :match '(:test 2)))
+    (should (widget-apply widget :match '(:test ".*")))
+    (should-not (widget-apply widget :match '(:test ignore)))))
+
+(ert-deftest widget-test-choice-match-some-inline ()
+  "Test that a choice widget with some inline members can match its values."
+  (let* ((lst '(list string
+                     (choice (const t)
+                             (list :inline t symbol number)
+                             (list :inline t symbol regexp))))
+         (widget (widget-convert lst)))
+    (should-not (widget-apply widget :match nil))
+    (should (widget-apply widget :match '("" t)))
+    (should (widget-apply widget :match '("" :test 2)))
+    (should (widget-apply widget :match '("" :test ".*")))
+    (should-not (widget-apply widget :match '(:test ignore)))))
+
+(ert-deftest widget-test-inline-p ()
+  "Test `widget-inline-p'.
+For widgets without an :inline t property, `widget-inline-p' has to return nil.
+But if the widget is a choice widget, it has to return nil if passed nil as
+the bubblep argument, or non-nil if one of the members of the choice widget has
+an :inline t property and we pass a non-nil bubblep argument.  If no members of
+the choice widget have an :inline t property, then `widget-inline-p' has to
+return nil, even with a non-nil bubblep argument."
+  (with-temp-buffer
+    (widget-insert "Testing.\n\n")
+    (let* ((widget (widget-create 'repeat
+                                  :value '(nil)
+                                  '(choice (const nil) (const t)
+                                           (list :inline t symbol number))
+                                  '(choice (const nil) (const t)
+                                           (list function string))))
+           (children (widget-get widget :children))
+           (child-1 (car children))
+           (child-2 (cadr children)))
+      (should-not (widget-inline-p widget))
+      (should-not (widget-inline-p child-1))
+      (should (widget-inline-p child-1 'bubble))
+      (should-not (widget-inline-p child-2))
+      (should-not (widget-inline-p child-2 'bubble)))))
+
+(ert-deftest widget-test-repeat-can-handle-choice ()
+  "Test that we can create a repeat widget with a choice correctly."
+  (with-temp-buffer
+    (widget-insert "Testing.\n\n")
+    (let* ((widget (widget-create 'repeat
+                                  :entry-format "%i %d %v"
+                                  :value '((:test 2))
+                                  '(choice (const nil) (const t)
+                                           (list symbol number))))
+           (child (car (widget-get widget :children))))
+      (widget-insert "\n")
+      (use-local-map widget-keymap)
+      (widget-setup)
+      (should child)
+      (should (equal (widget-value widget) '((:test 2)))))))
+
+(ert-deftest widget-test-repeat-can-handle-inlinable-choice ()
+  "Test that we can create a repeat widget with an inlinable choice correctly."
+  (with-temp-buffer
+    (widget-insert "Testing.\n\n")
+    (let* ((widget (widget-create 'repeat
+                                  :entry-format "%i %d %v"
+                                  :value '(:test 2)
+                                  '(choice (const nil) (const t)
+                                           (list :inline t symbol number))))
+           (child (widget-get widget :children)))
+      (widget-insert "\n")
+      (use-local-map widget-keymap)
+      (widget-setup)
+      (should child)
+      (should (equal (widget-value widget) '(:test 2))))))
+
+(ert-deftest widget-test-list-can-handle-choice ()
+  "Test that we can create a list widget with a choice correctly."
+  (with-temp-buffer
+    (widget-insert "Testing.\n\n")
+    (let* ((widget (widget-create 'list
+                                  :value '((1 "One"))
+                                  '(choice string
+                                           (list number string))))
+           (child (car (widget-get widget :children))))
+      (widget-insert "\n")
+      (use-local-map widget-keymap)
+      (widget-setup)
+      (should child)
+      (should (equal (widget-value widget) '((1 "One")))))))
+
+(ert-deftest widget-test-list-can-handle-inlinable-choice ()
+  "Test that we can create a list widget with an inlinable choice correctly."
+  (with-temp-buffer
+    (widget-insert "Testing.\n\n")
+    (let* ((widget (widget-create 'list
+                                  :value '(1 "One")
+                                  '(choice string
+                                           (list :inline t number string))))
+           (child (car (widget-get widget :children))))
+      (widget-insert "\n")
+      (use-local-map widget-keymap)
+      (widget-setup)
+      (should child)
+      (should (equal (widget-value widget) '(1 "One"))))))
+
+(ert-deftest widget-test-option-can-handle-choice ()
+  "Test that we can create a option widget with a choice correctly."
+  (with-temp-buffer
+    (widget-insert "Testing.\n\n")
+    (let* ((widget (widget-create 'repeat
+                                  :value '(("foo"))
+                                  '(list (option
+                                          (choice string
+                                                  (list :inline t
+                                                        number string))))))
+           (child (car (widget-get widget :children))))
+      (widget-insert "\n")
+      (use-local-map widget-keymap)
+      (widget-setup)
+      (should child)
+      (should (equal (widget-value widget) '(("foo")))))))
+
+(ert-deftest widget-test-option-can-handle-inlinable-choice ()
+  "Test that we can create a option widget with an inlinable choice correctly."
+  (with-temp-buffer
+    (widget-insert "Testing.\n\n")
+    (let* ((widget (widget-create 'repeat
+                                  :value '((1 "One"))
+                                  '(list (option
+                                          (choice string
+                                                  (list :inline t
+                                                        number string))))))
+           (child (car (widget-get widget :children))))
+      (widget-insert "\n")
+      (use-local-map widget-keymap)
+      (widget-setup)
+      (should child)
+      (should (equal (widget-value widget) '((1 "One")))))))
+
 ;;; wid-edit-tests.el ends here