From 7b61ba023d788d2946ff20e2b6a4828aa9df634c Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Fri, 2 Apr 2010 18:53:29 +0000
Subject: [PATCH] New library formlets

svn: r18720
---
 collects/tests/web-server/formlets-test.ss    | 51 +++++++++++++
 collects/web-server/formlets/input.ss         | 74 +++++++++++++++++++
 .../web-server/scribblings/formlets.scrbl     | 30 +++++++-
 3 files changed, 153 insertions(+), 2 deletions(-)

diff --git a/collects/tests/web-server/formlets-test.ss b/collects/tests/web-server/formlets-test.ss
index 78eb6fb936..1d73f9c375 100644
--- a/collects/tests/web-server/formlets-test.ss
+++ b/collects/tests/web-server/formlets-test.ss
@@ -137,6 +137,19 @@
       (test-equal? "make-input"
                    (test-process (make-input (lambda (n) n)) empty)
                    #f)
+      
+      (test-equal? "make-input*"
+                   (map ->cons (test-process (make-input* (lambda (n) n)) (list (make-binding:form #"input_0" #"value"))))
+                   (list (cons #"input_0" #"value")))
+      (test-equal? "make-input*"
+                   (map ->cons (test-process (make-input* (lambda (n) n)) (list (make-binding:form #"input_0" #"value0")
+                                                                                (make-binding:form #"input_0" #"value1"))))
+                   (list (cons #"input_0" #"value0")
+                         (cons #"input_0" #"value1")))
+      (test-equal? "make-input*"
+                   (test-process (make-input* (lambda (n) n)) empty)
+                   empty)
+      
       (test-equal? "text-input"
                    (->cons (test-process (text-input) (list (make-binding:form #"input_0" #"value"))))
                    (cons #"input_0" #"value"))
@@ -147,6 +160,37 @@
                    (->cons (test-process (checkbox #"start" #t) (list (make-binding:form #"input_0" #"value"))))
                    (cons #"input_0" #"value"))
       
+      (test-equal? "multiselect-input"
+                   (test-process (multiselect-input (list 1 2 3))
+                                 (list (make-binding:form #"input_0" #"0")))
+                   (list 1))
+      (test-equal? "multiselect-input"
+                   (test-process (multiselect-input (list 1 2 3))
+                                 (list (make-binding:form #"input_0" #"0")
+                                       (make-binding:form #"input_0" #"2")))
+                   (list 1 3))
+      (test-equal? "multiselect-input"
+                   (test-process (multiselect-input (list 1 2 3))
+                                 empty)
+                   empty)
+      
+      ; XXX check output
+      
+      (test-equal? "select-input"
+                   (test-process (select-input (list 1 2 3))
+                                 (list (make-binding:form #"input_0" #"0")))
+                   1)
+      (test-equal? "select-input"
+                   (test-process (select-input (list 1 2 3))
+                                 (list (make-binding:form #"input_0" #"0")
+                                       (make-binding:form #"input_0" #"2")))
+                   1)
+      (test-exn "select-input"
+                exn?
+                (lambda ()
+                  (test-process (select-input (list 1 2 3))
+                                empty)))
+      
       (test-equal? "required" 
                    (test-process (required (text-input)) (list (make-binding:form #"input_0" #"value")))
                    #"value")
@@ -162,6 +206,10 @@
                    (test-process (default #"def" (text-input)) empty)
                    #"def")
       
+      (test-equal? "textarea-input"
+                   (test-process (textarea-input) (list (make-binding:form #"input_0" #"value")))
+                   "value")
+      
       (test-equal? "to-string"
                    (test-process (to-string (required (text-input))) (list (make-binding:form #"input_0" #"value")))
                    "value")
@@ -254,3 +302,6 @@
                                (list "Jay" (make-date 10 6) (make-date 10 8))))))
    
    ))
+
+(require schemeunit/text-ui)
+(run-tests all-formlets-tests)
\ No newline at end of file
diff --git a/collects/web-server/formlets/input.ss b/collects/web-server/formlets/input.ss
index c0b51f61f4..ae2ce89b02 100644
--- a/collects/web-server/formlets/input.ss
+++ b/collects/web-server/formlets/input.ss
@@ -9,6 +9,16 @@
 ; Low-level
 (define (next-name i)
   (values (format "input_~a" i) (add1 i)))
+(define (make-input* render)
+  (lambda (i)
+    (let-values ([(w i) (next-name i)])
+      (define wb (string->bytes/utf-8 w))
+      (values (list (render w))
+              (lambda (env) 
+                (for/list ([b (in-list env)]
+                           #:when (bytes=? wb (binding-id b)))
+                  b))
+              i))))
 (define (make-input render)
   (lambda (i)
     (let-values ([(w i) (next-name i)])
@@ -31,6 +41,7 @@
          default))))
 
 (provide/contract
+ [make-input* ((string? . -> . pretty-xexpr/c) . -> . (formlet/c (listof binding?)))]
  [make-input ((string? . -> . pretty-xexpr/c) . -> . (formlet/c (or/c false/c binding?)))]
  #;[binding:form-required (formlet/c (binding? . -> . bytes?))]
  #;[binding:form/default (bytes? . -> . (formlet/c (binding? . -> . bytes?)))])
@@ -110,7 +121,70 @@
 
 ; XXX button
 
+(define (multiselect-input l
+                       #:multiple? [multiple? #t]
+                       #:selected? [selected? (λ (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-select* "Invalid selection: ~e" i))))
+  (for ([e l])
+    (remember! e))
+  (cross
+   (pure
+    (lambda (bs)
+      (map (compose recall string->number
+                    bytes->string/utf-8
+                    binding:form-value)
+           bs)))
+   (make-input*
+    (lambda (name)
+      `(select (,@(if multiple? '([multiple "true"]) empty)
+                [name ,name])
+               ,@(for/list ([(vn e) (in-hash value->element)])
+                   (define v (number->string vn))
+                   `(option ([value ,v]
+                             ,@(if (selected? e)
+                                   '([selected "true"])
+                                   empty))
+                            ,(display e))))))))
+
+(define (select-input l 
+                      #:selected? [selected? (λ (x) #f)]
+                      #:display [display (λ (x) x)])
+  (cross
+   (pure first)
+   (multiselect-input l
+                  #:multiple? #f
+                  #:selected? selected?
+                  #:display display)))
+
+(define (textarea-input)
+  (to-string 
+   (required 
+    (make-input
+     (lambda (n)
+       (list 'textarea
+             (list (list 'name n))
+             ""))))))
+
 (provide/contract
+ [multiselect-input (->* (sequence?)
+                         (#:multiple? boolean?
+                          #:selected? (any/c . -> . boolean?)
+                          #:display (any/c . -> . pretty-xexpr/c))
+                         (formlet/c (listof any/c)))]
+ [select-input (->* (sequence?)
+                    (#:selected? (any/c . -> . boolean?)
+                     #:display (any/c . -> . pretty-xexpr/c))
+                    (formlet/c any/c))]
+ [textarea-input (-> (formlet/c string?))]
  [text-input (() 
         (#:value (or/c false/c bytes?)
                  #:size (or/c false/c exact-nonnegative-integer?)
diff --git a/collects/web-server/scribblings/formlets.scrbl b/collects/web-server/scribblings/formlets.scrbl
index 6dd1969584..376dd14926 100644
--- a/collects/web-server/scribblings/formlets.scrbl
+++ b/collects/web-server/scribblings/formlets.scrbl
@@ -206,6 +206,12 @@ These @tech{formlet}s are the main combinators for form input.
  extracted @scheme[binding].
 }
                                              
+@defproc[(make-input* [render (string? . -> . xexpr/c)])
+         (formlet/c (listof binding?))]{
+ This @tech{formlet} is rendered with @scheme[render], which is passed the input name, and results in all the
+ @scheme[binding]s that use the name.
+}
+                                             
 @defproc[(text-input [#:value value (or/c false/c bytes?) #f]
                      [#:size size (or/c false/c exact-nonnegative-integer?) #f]
                      [#:max-length max-length (or/c false/c exact-nonnegative-integer?) #f]
@@ -223,14 +229,34 @@ These @tech{formlet}s are the main combinators for form input.
         (formlet/c (or/c false/c binding?))]{
  This @tech{formlet} renders using an INPUT element with the PASSWORD type and the attributes given in the arguments.
 }
- 
+
+@defproc[(textarea-input)
+        (formlet/c string?)]{
+ This @tech{formlet} renders using an TEXTAREA element.
+}
+                                            
 @defproc[(checkbox [value bytes?]
                    [checked? boolean?]
                    [#:attributes attrs (listof (list/c symbol? string?)) empty])
          (formlet/c (or/c false/c binding?))]{
  This @tech{formlet} renders using a INPUT elemen with the CHECKBOX type and the attributes given in the arguments.
-}      
+}
                                              
+@defproc[(multiselect-input [l sequence?]
+                            [#:multiple? multiple? boolean? #t]
+                            [#:selected? selected? (any/c . -> . boolean?) (λ (x) #f)]
+                            [#:display display (any/c . -> . xexpr/c) (λ (x) x)])
+        (formlet/c list?)]{
+ This @tech{formlet} renders using an SELECT element with an OPTION for each element of the sequence. If @scheme[multiple?] is @scheme[#t], then multiple options may be selected. An element is selected if @scheme[selected?] returns @scheme[#t]. Elements are displayed with @scheme[display].
+}
+
+@defproc[(select-input [l sequence?]
+                       [#:selected? selected? (any/c . -> . boolean?) (λ (x) #f)]
+                       [#:display display (any/c . -> . xexpr/c) (λ (x) x)])
+        (formlet/c any/c)]{
+ This @tech{formlet} renders using an SELECT element with an OPTION for each element of the sequence. An element is selected if @scheme[selected?] returns @scheme[#t]. Elements are displayed with @scheme[display].
+}
+                          
 @defproc[(required [f (formlet/c (or/c false/c binding?))])
          (formlet/c bytes?)]{
  Constructs a @tech{formlet} that extracts the @scheme[binding:form-value] from the binding produced by @scheme[f], or errors.