From afce8db9e42ab20bf0e27fb087b9c17a41aeb70a Mon Sep 17 00:00:00 2001 From: Mauro Aranda Date: Mon, 16 Nov 2020 20:05:04 -0300 Subject: [PATCH] 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. --- lisp/wid-edit.el | 72 +++++++++++++---- test/lisp/wid-edit-tests.el | 153 ++++++++++++++++++++++++++++++++++++ 2 files changed, 211 insertions(+), 14 deletions(-) diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 4e2cf7416d..8250316bcc 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -591,9 +591,25 @@ widget-default-get (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 @@ widget-choice-value-create (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 @@ widget-choice-value-create 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 @@ widget-checklist-add-item (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 @@ widget-editable-list-value-create (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 @@ widget-group-value-create (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 @@ widget-alist-convert-option `(cons :format "Key: %v" ,key-type ,value-type))) (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 @@ widget-choice-prompt-value (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)) + (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 4508b68023..1bd429736e 100644 --- a/test/lisp/wid-edit-tests.el +++ b/test/lisp/wid-edit-tests.el @@ -148,4 +148,157 @@ widget-test-moving-editable-list-item ;; 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 -- 2.29.2