Adding formlet*

collects/tests/web-server/formlets/formlet-star.rkt

@@ -0,0 +1,108 @@
+#lang racket
+(require web-server/formlets
+         web-server/formlets/new-syntax
+         tests/eli-tester
+         web-server/http
+         net/url)
+
+(define (make-test-req bs)
+  (make-request #"GET" (string->url "http://test.com") empty (delay bs) #f "127.0.0.1" 80 "127.0.0.1"))
+(define (make-test-bindings . bs)
+  (for/list ([b (in-list bs)]
+             [i (in-naturals)])
+    (make-binding:form (string->bytes/utf-8 (format "input_~a" i)) b)))
+(define-syntax-rule (test-formlet formlet display args result)
+  (test (formlet-display formlet) => display
+        (formlet-process formlet (make-test-req (make-test-bindings . args))) => result))
+
+(test
+ (test-formlet 
+  (formlet*
+   (list 'p (input-string . =>* . name))
+   name)
+  '((p () (input ((name "input_0") (type "text")))))
+  (#"Jay")
+  '("Jay"))
+ 
+ (test-formlet 
+  (formlet*
+   `(p ,(input-string . =>* . name))
+   name)
+  '((p () (input ((name "input_0") (type "text")))))
+  (#"Jay")
+  '("Jay"))
+ 
+ (test-formlet 
+  (formlet*
+   (#%# `(p ,(input-string . =>* . name)))
+   name)
+  '((p () (input ((name "input_0") (type "text")))))
+  (#"Jay")
+  '("Jay"))
+ 
+ (test-formlet 
+  (formlet*
+   `(div 
+     ,@(for/list ([i (in-range 3)])
+         `(p ,(input-string . =>* . name))))
+   name)
+  '((div ()
+         (p () (input ((name "input_0") (type "text"))))
+         (p () (input ((name "input_1") (type "text"))))
+         (p () (input ((name "input_2") (type "text"))))))
+  (#"Jay" #"Ness" #"Pokey")
+  (list "Jay" "Ness" "Pokey"))
+ 
+ (test-formlet 
+  (formlet*
+   `(div 
+     ,@(for/list ([i (in-range 0)])
+         `(p ,(input-string . =>* . name))))
+   name)
+  '((div ()))
+  ()
+  (list))
+ 
+ (local [(define two-names
+           (formlet (#%# ,(input-string . => . first-name)
+                         ,(input-string . => . last-name))
+                    (values first-name last-name)))]
+   (test-formlet 
+    (formlet*
+     `(div 
+       ,@(for/list ([i (in-range 3)])
+           `(p ,(two-names . =>* . (values first-name last-name)))))
+     (map string-append first-name (for/list ([e (in-list first-name)]) " ") last-name))
+    '((div ()
+           (p () (input ((name "input_0") (type "text"))) (input ((name "input_1") (type "text"))))
+           (p () (input ((name "input_2") (type "text"))) (input ((name "input_3") (type "text"))))
+           (p () (input ((name "input_4") (type "text"))) (input ((name "input_5") (type "text"))))))
+    (#"Jay" #"McCarthy"
+     #"Ness" #"Ninten"
+     #"Pokey" #"Porkey")
+    (list "Jay McCarthy" 
+          "Ness Ninten"
+          "Pokey Porkey")))
+ 
+ (local [(define two-names
+           (formlet* (#%# (input-string . =>* . first-name)
+                          (input-string . =>* . last-name))
+                     (values (first first-name) (first last-name))))]
+   (test-formlet 
+    (formlet*
+     `(div 
+       ,@(for/list ([i (in-range 3)])
+           `(p ,(two-names . =>* . (values first-name last-name)))))
+     (map string-append first-name (for/list ([e (in-list first-name)]) " ") last-name))
+    '((div ()
+           (p () (input ((name "input_0") (type "text"))) (input ((name "input_1") (type "text"))))
+           (p () (input ((name "input_2") (type "text"))) (input ((name "input_3") (type "text"))))
+           (p () (input ((name "input_4") (type "text"))) (input ((name "input_5") (type "text"))))))
+    (#"Jay" #"McCarthy"
+     #"Ness" #"Ninten"
+     #"Pokey" #"Porkey")
+    (list "Jay McCarthy" 
+          "Ness Ninten"
+          "Pokey Porkey")))
+ 
+ )

collects/web-server/formlets.rkt

@@ -1,11 +1,13 @@
 #lang racket
 (require web-server/formlets/syntax
+         web-server/formlets/new-syntax
          web-server/formlets/input
          web-server/formlets/servlet
          web-server/formlets/lib)
 (provide (all-from-out web-server/formlets/servlet)
          (all-from-out web-server/formlets/input)
          (all-from-out web-server/formlets/syntax)
+         (all-from-out web-server/formlets/new-syntax)
          formlet/c
          formlet-display
          formlet-process)

collects/web-server/formlets/lib.rkt

@@ -53,7 +53,7 @@
 (define (tag-xexpr t ats f)
   (lambda (i)
     (let-values ([(x p i) (f i)])
-      (values (list (list* t ats x))  p i))))
+      (values (list (list* t ats x)) p i))))
 
 ; Helpers
 (define (formlet-display f)
@@ -87,7 +87,7 @@
  [pure (alpha
         . -> . (formlet/c alpha))]
  [cross ((formlet/c procedure?) formlet*/c . -> . formlet*/c)]
- [cross* (((formlet/c (() () #:rest (listof alpha) . ->* . beta)))
+ [cross* (((formlet/c (unconstrained-domain-> beta)))
           () #:rest (listof (formlet/c alpha))
           . ->* . (formlet/c beta))]
  [xml-forest (xexpr-forest/c . -> . (formlet/c procedure?))]

collects/web-server/formlets/new-syntax.rkt

@@ -0,0 +1,94 @@
+#lang racket
+(require (for-syntax racket 
+                     syntax/parse
+                     syntax/strip-context)
+         racket/stxparam
+         "lib.rkt"
+         "syntax.rkt"
+         (for-syntax "lib.rkt"))
+
+(define-syntax-parameter =>*
+  (λ (stx) (raise-syntax-error '=>* "Only allowed inside formlet*" stx)))
+
+(define (snoc x l) (append l (list x)))
+
+(struct label-formlet (p))
+
+(define (label-formlet-answers labels formlet)
+  (label-formlet
+   (cross (pure (λ anss
+                  (λ (answers) 
+                    (for ([label (in-list labels)]
+                          [ans (in-list anss)])
+                      (hash-update! answers label (curry snoc ans) empty)))))
+          formlet)))
+
+(define xexpr-forest->label-formlet
+  (match-lambda
+    [(list)
+     (pure (λ (x) x))]
+    [(list-rest xe xf)
+     (cross* (pure (lambda (xe-populate-hash! xf-populate-hash!)
+                     (lambda (answers)
+                       (xe-populate-hash! answers)
+                       (xf-populate-hash! answers))))
+             (xexpr->label-formlet xe)
+             (xexpr-forest->label-formlet xf))]))
+
+(define xexpr->label-formlet
+  (match-lambda
+    [(#%#-mark l)
+     (xexpr-forest->label-formlet l)]
+    [(list (? symbol? tag) (list (list (? symbol? attr) (? string? str)) ...) xexpr ...)
+     (tag-xexpr tag (map list attr str)
+                (xexpr-forest->label-formlet xexpr))]
+    [(list (? symbol? tag) xexpr ...)
+     (tag-xexpr tag empty
+                (xexpr-forest->label-formlet xexpr))]
+    [(label-formlet p)
+     p]
+    [(? string? s)
+     (text s)]))
+
+(define (label-formlet-cross handler xexpr/labeled-formlets)
+  (cross (pure (λ (populate-hash!)
+                 (define ht (make-hasheq))
+                 (populate-hash! ht)
+                 (handler ht)))
+         (xexpr->label-formlet xexpr/labeled-formlets)))
+
+(struct #%#-mark (l))
+(define-syntax-rule (inner-#%# e ...) (#%#-mark (list e ...)))
+
+(define-syntax (formlet* stx)
+  (syntax-case stx ()
+    [(_ q e)
+     (local [(define label->name (make-hash))
+             (define (this-=>* stx)
+               (syntax-parse stx
+                             #:literals (values)
+                             [(=>* formlet:expr name:id)
+                              #'(=>* formlet (values name))]
+                             [(_ formlet:expr (values name:id ...))
+                              (define names (syntax->list #'(name ...)))
+                              (define labels (map (compose gensym syntax->datum) names))
+                              (for ([label (in-list labels)]
+                                    [name (in-list names)])
+                                (hash-set! label->name label (replace-context #'e name)))
+                              #`(label-formlet-answers '#,labels formlet)]))
+             (define q-raw 
+               (local-expand #`(syntax-parameterize ([=>* #,this-=>*]
+                                                     [#%# (make-rename-transformer #'inner-#%#)])
+                                                    q)
+                             'expression empty))]
+       (with-syntax ([((label . name) ...)
+                      (for/list ([(k v) (in-hash label->name)])
+                        (cons k v))])
+         (quasisyntax/loc stx
+           (label-formlet-cross (lambda (labeled)
+                                  (let ([name (hash-ref labeled 'label empty)]
+                                        ...)
+                                    e))
+                                #,q-raw))))]))
+
+(provide formlet* =>*)

collects/web-server/formlets/syntax.rkt

@@ -1,9 +1,12 @@
 #lang racket
-(require (for-syntax racket syntax/parse)
+(require (for-syntax racket 
+                     syntax/parse)
+         racket/stxparam
          "lib.rkt"
          (for-syntax "lib.rkt"))
 
-(define-syntax (#%# stx) (raise-syntax-error '#%# "Only allowed inside formlet" stx))
+(define-syntax-parameter #%# 
+  (λ (stx) (raise-syntax-error '#%# "Only allowed inside formlet or formlet*" stx)))
 
 (define-for-syntax (cross-of stx)
   (syntax-parse 
@@ -56,22 +59,4 @@
        (cross (pure (match-lambda [#,(cross-of #'q) e]))
               #,(circ-of #'q)))]))
 
-(provide formlet #%#)
-
-(require "input.rkt")
-(define date-formlet
-  (formlet
-   (div
-    "Month:" ,{input-int . => . month}
-    "Day:" ,{input-int . => . day})
-   (values month day)))
-
-(define travel-formlet
-  (formlet
-   (div
-    "Name:" ,{input-string . => . name}
-    (div
-     "Arrive:" ,{date-formlet . => . (values arrive-m arrive-d)}
-     "Depart:" ,{date-formlet . => . (values depart-m depart-d)})
-    ,@(list "1" "2" "3"))
-   (values name arrive-m arrive-d depart-m depart-d)))
+(provide formlet #%#)

collects/web-server/scribblings/formlets.scrbl

@@ -94,30 +94,93 @@ bindings for these names to @racket[formlet-process], the following list is retu
 
 The rest of the manual gives the details of @tech{formlet} usage and extension.
 
-@section{Syntactic Shorthand}
+@section{Static Syntactic Shorthand}
 
 @(require (for-label web-server/formlets/syntax))
 @defmodule[web-server/formlets/syntax]{
 
 Most users will want to use the syntactic shorthand for creating @tech{formlet}s.
 
-@defform[(formlet rendering yields-expr)]{
- Constructs a @tech{formlet} with the specified @racket[rendering] and the processing
- resulting in the @racket[yields-expr] expression. The @racket[rendering] form is a quasiquoted
- @xexpr, with two special caveats:
+@defform[(formlet rendering-xexpr yields-expr)]{
+ Constructs a @tech{formlet} with the specified @racket[rendering-xexpr] and the processing
+ result is the evaluation of the @racket[yields-expr] expression. The @racket[rendering-xexpr] form is a quasiquoted
+ syntactic @xexpr, with three special caveats:
  
  @racket[,{_formlet-expr . => . _name}] embeds the
- @tech{formlet} given by @racket[_formlet-expr]; the result of this processing this formlet is
+ @tech{formlet} given by @racket[_formlet-expr]; the result of processing this formlet is
  available in the @racket[yields-expr] as @racket[_name]. 
  
  @racket[,{_formlet-expr . => . (values _name ...)}] embeds the
- @tech{formlet} given by @racket[_formlet-expr]; the results of this processing this formlet is
+ @tech{formlet} given by @racket[_formlet-expr]; the results of processing this formlet is
  available in the @racket[yields-expr] as @racket[_name ...]. 
  
  @racket[(#%# _xexpr ...)] renders an @xexpr forest.
+ 
+ These forms @emph{may not} appear nested inside @racket[unquote] or @racket[unquote-splicing]. For example, this is illegal:
+ @racketblock[
+  (formlet (div ,@(for/list ([i (in-range 10)])
+                    `(p ,(text-input . => . name))))
+           name)
+  ]
 }
 
-@defidform[#%#]{Only allowed inside @racket[formlet].}
+@defidform[#%#]{Only allowed inside @racket[formlet] and @racket[formlet*].}
+
+}
+
+@section{Dynamic Syntactic Shorthand}
+
+@(require (for-label web-server/formlets/new-syntax))
+@defmodule[web-server/formlets/new-syntax]{
+
+The @racket[formlet] syntax is too restrictive for some applications because it forces the @racket[_rendering]
+to be @emph{syntactically} an @|xexpr|. You may discover you want to use a more "dynamic" shorthand.
+
+@defform[(formlet* rendering-expr yields-expr)]{
+ Constructs a @tech{formlet} where @racket[rendering-expr] is evaluated (with caveats) to construct the rendering
+ and the processing result is the evaluation of the the @racket[yields-expr] expression.
+ The @racket[rendering-expr] should evaluate to an "@xexpr" that may embed the results of the following forms
+ that only have meaning within @racket[formlet*]:
+ 
+ @racket[{_formlet-expr . =>* . _name}] embeds the
+ @tech{formlet} given by @racket[_formlet-expr]; the result of processing this formlet is
+ available in the @racket[yields-expr] as @racket[_name]. 
+ 
+ @racket[{_formlet-expr . =>* . (values _name ...)}] embeds the
+ @tech{formlet} given by @racket[_formlet-expr]; the results of processing this formlet is
+ available in the @racket[yields-expr] as @racket[_name ...]. 
+ 
+ @racket[(#%# _xexpr-expr ...)] renders an @xexpr forest.
+ 
+ Each of these forms evaluates to an opaque value that @racket[rendering-expr] may not manipulate in any way,
+ but if it is returned to @racket[formlet*] as part of an "@xexpr" it will be rendered and the formlets processing
+ stages will be executed, etc.
+ 
+ Because these forms @emph{may} appear anywhere in @racket[rendering-expr], they may be duplicated. Therefore, 
+ the formlet may render (and be processed) multiple times. Thus, in @racket[yields-expr] the formlet result names are
+ bound to lists of results rather than single results as in @racket[formlet]. The result list is ordered according 
+ to the order of the formlets in the result of @racket[rendering-expr]. For example, in 
+ @racketblock[
+  (formlet* `(div ,@(for/list ([i (in-range 1 10)])
+                      `(p ,(number->string i)
+                          ,(text-input . =>* . name))))
+            name)
+  ]
+ @racket[name] is bound to a list of strings, not a single string, where the first element is the string that
+ was inputted next to the string @litchar{1} on the Web page.
+ 
+ In this example, it is clear that this is the desired behavior. However, sometimes the value of a formlet's
+ result may be surprising. For example, in
+ @racketblock[
+  (formlet* `(div (p ,(text-input . =>* . name)))
+            name)
+  ]
+ @racket[name] is bound to a list of strings, because @racket[formlet*] cannot syntactically determine if
+ the formlet whose result is bound to @racket[name] is used many times.
+ 
+}
+
+@defidform[=>*]{Only allowed inside @racket[formlet*].}
 
 }