Adding radio and checkbox groups to formlets

collects/tests/web-server/formlets-test.rkt

@@ -259,13 +259,67 @@
                    (cons #"input_0" #"value"))
       (test-equal? "radio"
                    (test-display (radio #"start" #t))
-                   '((input ((name "input_0") (type "radio") (checked "true")))))
+                   '((input ((name "input_0") (type "radio") (value "start") (checked "true")))))
       (test-equal? "radio"
                    (test-display (radio #"start" #f))
-                   '((input ((name "input_0") (type "radio")))))
+                   '((input ((name "input_0") (type "radio") (value "start")))))
       (test-equal? "radio"
                    (test-display (radio #"start" #t #:attributes '([test "Test"])))
-                   '((input ((name "input_0") (type "radio") (checked "true") (test "Test")))))
+                   '((input ((name "input_0") (type "radio") (value "start") (checked "true") (test "Test")))))
+
+      ; radio-group
+      (test-equal? "radio-group"
+                   (test-process (radio-group (list "1" "2" "3"))
+                                 (list (make-binding:form #"input_0" #"0")))
+                   "1")
+      (test-equal? "radio-group"
+                   (test-process (radio-group (list 1 2 3) #:display number->string)
+                                 (list (make-binding:form #"input_0" #"0")))
+                   1)
+      (test-equal? "radio-group"
+                   (test-process (radio-group (list 1 2 3) #:display number->string)
+                                 (list (make-binding:form #"input_0" #"0")
+                                       (make-binding:form #"input_0" #"1")))
+                   1)
+      (test-equal? "radio-group"
+                   (test-display (radio-group 
+                                  (list 1 2 3)
+                                  #:display number->string 
+                                  #:checked? even?
+                                  #:attributes (λ (e) (list (list 'plus-one (number->string (add1 e)))))))
+                   '((input ((name "input_0") (type "radio") (value "0") (plus-one "2")))
+                     "1"
+                     (input ((name "input_0") (type "radio") (value "1") (checked "true") (plus-one "3")))
+                     "2"
+                     (input ((name "input_0") (type "radio") (value "2") (plus-one "4")))
+                     "3"))
+
+      ; checkbox-group
+      (test-equal? "checkbox-group"
+                   (test-process (checkbox-group (list "1" "2" "3"))
+                                 (list (make-binding:form #"input_0" #"0")))
+                   (list "1"))
+      (test-equal? "checkbox-group"
+                   (test-process (checkbox-group (list 1 2 3) #:display number->string)
+                                 (list (make-binding:form #"input_0" #"0")))
+                   (list 1))
+      (test-equal? "checkbox-group"
+                   (test-process (checkbox-group (list 1 2 3) #:display number->string)
+                                 (list (make-binding:form #"input_0" #"0")
+                                       (make-binding:form #"input_0" #"1")))
+                   (list 1 2))
+      (test-equal? "checkbox-group"
+                   (test-display (checkbox-group 
+                                  (list 1 2 3)
+                                  #:display number->string 
+                                  #:checked? even?
+                                  #:attributes (λ (e) (list (list 'plus-one (number->string (add1 e)))))))
+                   '((input ((name "input_0") (type "checkbox") (value "0") (plus-one "2")))
+                     "1"
+                     (input ((name "input_0") (type "checkbox") (value "1") (checked "true") (plus-one "3")))
+                     "2"
+                     (input ((name "input_0") (type "checkbox") (value "2") (plus-one "4")))
+                     "3"))
       
       ; submit
       (test-equal? "submit"

collects/web-server/formlets/input.rkt

@@ -10,17 +10,22 @@
 (define (next-name i)
   (values (format "input_~a" i) (add1 i)))
 
-(define (make-input* render)
+(define (make-input*/forest render)
   (lambda (i)
     (let-values ([(w i) (next-name i)])
       (define wb (string->bytes/utf-8 w))
-      (values (list (render w))
+      (values (render w)
               (lambda (env) 
                 (for/list ([b (in-list env)]
                            #:when (bytes=? wb (binding-id b)))
                   b))
               i))))
 
+(define (make-input* render)
+  (make-input*/forest
+   (lambda (w)
+     (list (render w)))))
+
 (define (make-input render)
   (lambda (i)
     (let-values ([(w i) (next-name i)])
@@ -109,9 +114,74 @@
                #:attributes [attrs empty])
   (input
    #:type "radio"
+   #:value value
    #:attributes
    (if checked? (append (list (list 'checked "true")) attrs) attrs)))
 
+(define (input-group l
+                     #:kind kind
+                     #:attributes [attrs (λ (x) empty)]
+                     #:checked? [checked? (λ (x) #f)]
+                     #:display [display (λ (x) x)])
+  (define value->element (make-hasheq))
+  (define i 0)
+  (define (remember! e)
+    (define this-i
+      (begin0 i (set! i (add1 i))))
+    (hash-set! value->element this-i e))
+  (define (recall i)
+    (hash-ref value->element i
+              (λ () (error 'input-group "Invalid selection: ~e" i))))
+  (for ([e l])
+    (remember! e))
+  (define (radio-first l)
+    (if (string=? kind "radio")
+        (first l)
+        l))
+  (cross
+   (pure
+    (lambda (bs)
+      (radio-first
+       (map (compose recall string->number
+                     bytes->string/utf-8
+                     binding:form-value)
+            bs))))
+   (make-input*/forest
+    (lambda (name)
+      (apply append
+             (for/list ([vn (in-range i)])
+                       (define e (hash-ref value->element vn))
+                       (define v (number->string vn))
+                       (list
+                        `(input ([name ,name]
+                                 [type ,kind]
+                                 [value ,v]
+                                 ,@(if (checked? e)
+                                       '([checked "true"])
+                                       empty)
+                                 ,@(attrs e)))
+                        (display e))))))))
+
+(define (radio-group l 
+                     #:attributes [attrs (λ (x) empty)]
+                     #:checked? [checked? (λ (x) #f)]
+                     #:display [display (λ (x) x)])
+  (input-group l
+               #:kind "radio"
+               #:attributes attrs
+               #:checked? checked?
+               #:display display))
+
+(define (checkbox-group l 
+                     #:attributes [attrs (λ (x) empty)]
+                     #:checked? [checked? (λ (x) #f)]
+                     #:display [display (λ (x) x)])
+  (input-group l
+               #:kind "checkbox"
+               #:attributes attrs
+               #:checked? checked?
+               #:display display))
+
 (define (submit value
                 #:attributes [attrs empty])
   (input
@@ -265,6 +335,20 @@
          (#:attributes (listof (list/c symbol? string?)))
          . ->* .
          (formlet/c (or/c false/c binding?)))]
+ [radio-group ((sequence?)
+               (#:attributes 
+                (-> any/c (listof (list/c symbol? string?)))
+                #:checked? (any/c . -> . boolean?)
+                #:display (any/c . -> . pretty-xexpr/c))
+               . ->* .
+               (formlet/c any/c))]
+ [checkbox-group ((sequence?)
+                  (#:attributes 
+                   (-> any/c (listof (list/c symbol? string?)))
+                   #:checked? (any/c . -> . boolean?)
+                   #:display (any/c . -> . pretty-xexpr/c))
+                  . ->* .
+                  (formlet/c (listof any/c)))]
  [submit ((bytes?)         
           (#:attributes (listof (list/c symbol? string?)))
           . ->* .

collects/web-server/scribblings/formlets.scrbl

@@ -338,6 +338,34 @@ These @tech{formlet}s are the main combinators for form input.
  This @tech{formlet} renders using an INPUT element with the RADIO type and the attributes given in the arguments.
 }
 
+@defproc[(radio-group [l sequence?]
+                      [#:attributes attrs (any/c . -> . (listof (list/c symbol? string?))) (λ (x) empty)]
+                      [#:checked? checked? (any/c . -> . boolean?) (λ (x) #f)]
+                      [#:display display (any/c . -> . xexpr/c) (λ (x) x)])
+        (formlet/c any/c)]{
+
+  This @tech{formlet} renders using a sequence of INPUT elements of
+RADIO type where each element gets its attributes from @racket[attrs]
+that share a single NAME. An element is checked if @racket[checked?]
+returns @racket[#t]. Elements are followed by the results of
+@racket[display]. The result of processing this formlet is a single
+element of the sequence.
+}
+
+@defproc[(checkbox-group [l sequence?]
+                      [#:attributes attrs (any/c . -> . (listof (list/c symbol? string?))) (λ (x) empty)]
+                      [#:checked? checked? (any/c . -> . boolean?) (λ (x) #f)]
+                      [#:display display (any/c . -> . xexpr/c) (λ (x) x)])
+        (formlet/c (listof any/c))]{
+
+  This @tech{formlet} renders using a sequence of INPUT elements of
+CHECKBOX type where each element gets its attributes from
+@racket[attrs] that share a single NAME. An element is checked if
+@racket[checked?]  returns @racket[#t]. Elements are followed by the
+results of @racket[display]. The result of processing this formlet is
+a list of elements of the sequence.
+}
+
 @defproc[(submit [value bytes?]
                  [#:attributes attrs (listof (list/c symbol? string?)) empty])
          (formlet/c (or/c false/c binding?))]{