Adding formlets

svn: r11782

collects/web-server/formlets/date.ss

@@ -0,0 +1,63 @@
+#lang scheme
+(require web-server/formlets/formlets)
+
+(define-struct date (month day))
+(define (date->xml d)
+  (format "~a/~a"
+          (date-month d)
+          (date-day d)))
+
+(define (submit t)
+  `(input ([type "submit"]) ,t))
+
+(define date-formlet
+  (formlet
+   (div
+    "Month:" ,{input-int . => . month}
+    "Day:" ,{input-int . => . day})
+   (make-date month day)))
+
+(formlet-display date-formlet)
+
+(define travel-formlet
+  (formlet
+   (#%#
+    "Name:" ,{input-string . => . name}
+    (div
+     "Arrive:" ,{date-formlet . => . arrive}
+     "Depart:" ,{date-formlet . => . depart})
+    ,@(list "1" "2" "3")
+    ,(submit "Submit"))
+   (list name arrive depart)))
+
+(formlet-display travel-formlet)
+
+(define display-itinernary
+  (match-lambda
+    [(list name arrive depart)
+     `(html
+       (head (title "Itinerary"))
+       (body
+        "Itinerary for: " ,name
+        "Arriving:" ,(date->xml arrive)
+        "Departing:" ,(date->xml depart)))]))
+
+(require net/url
+         web-server/servlet)
+(formlet-process travel-formlet
+                 (make-request 'get (string->url "http://test.com")
+                               empty
+                               (list (make-binding:form #"input_0" #"Jay")
+                                     (make-binding:form #"input_1" #"10")
+                                     (make-binding:form #"input_2" #"6")
+                                     (make-binding:form #"input_3" #"10")
+                                     (make-binding:form #"input_4" #"8"))
+                               #f "127.0.0.1" 80 "127.0.0.1"))
+
+(require web-server/formlets/servlet)
+
+(define (start request)
+  (display-itinernary
+   (send/formlet
+    travel-formlet)))
+

collects/web-server/formlets/formlets.ss

@@ -0,0 +1,52 @@
+#lang scheme
+(require (for-syntax scheme)
+         "lib.ss"
+         (for-syntax "lib.ss"))
+
+(define-for-syntax (cross-of stx)
+  (syntax-case stx (unquote unquote-splicing => #%#)
+    [s (string? (syntax->datum #'s))
+       (syntax/loc stx empty)]
+    [,(formlet . => . name) (syntax/loc stx name)]
+    [,e (syntax/loc stx empty)]
+    [,@e (syntax/loc stx empty)]
+    [(#%# n ...)
+     (quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]
+    [(t ([k v] ...) n ...)
+     (quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]
+    [(t n ...)
+     (quasisyntax/loc stx (list #,@(map cross-of (syntax->list #'(n ...)))))]))
+
+(define-for-syntax (circ-of stx)
+  (syntax-case stx (unquote unquote-splicing => #%#)
+    [s (string? (syntax->datum #'s))
+       (syntax/loc stx (text s))]
+    [,(formlet . => . name) (syntax/loc stx formlet)]
+    [,e (syntax/loc stx (xml e))]
+    [,@e (syntax/loc stx (xml-forest e))]
+    [(#%# n ...)
+     (let ([n-cross (map cross-of (syntax->list #'(n ...)))])
+       (quasisyntax/loc stx
+         (cross*
+          (pure (match-lambda*
+                  [(list #,@n-cross)
+                   (list #,@n-cross)]))
+          #,@(map circ-of (syntax->list #'(n ...))))))]
+    [(t ([k v] ...) n ...)
+     (quasisyntax/loc stx
+       (tag-xexpr 't '([k v] ...)
+                 #,(circ-of (syntax/loc stx (#%# n ...)))))]
+    [(t n ...)
+     (quasisyntax/loc stx
+       (tag-xexpr 't empty
+                 #,(circ-of (syntax/loc stx (#%# n ...)))))]))
+
+(define-syntax (formlet stx)
+  (syntax-case stx ()
+    [(_ q e)
+     (quasisyntax/loc stx
+       (cross (pure (match-lambda [#,(cross-of #'q) e]))
+              #,(circ-of #'q)))]))
+
+(provide (all-defined-out)
+         (all-from-out "lib.ss"))

collects/web-server/formlets/lib.ss

@@ -0,0 +1,126 @@
+#lang scheme
+(require web-server/private/request-structs
+         xml)
+
+; Combinators
+(define (const x) (lambda _ x))
+(define (id x) x)
+
+; Formlets
+(define (pure x)
+  (lambda (i)
+    (values empty (const x) i)))
+
+(define (cross f p)
+  (lambda (i)
+    (let*-values ([(x1 g i) (f i)]
+                  [(x2 q i) (p i)])
+      (values (append x1 x2)
+              (lambda (env)
+                (let ([ge (g env)]
+                      [qe (q env)])
+                  (ge qe)))
+              i))))
+
+;; This is gross because OCaml auto-curries
+(define (cross* f . gs)
+  (lambda (i)
+    (let*-values ([(fx fp fi) (f i)]
+                  [(gs-x gs-p gs-i)
+                   (let loop ([gs gs]
+                              [xs empty]
+                              [ps empty]
+                              [i fi])
+                     (if (empty? gs)
+                         (values (reverse xs) (reverse ps) i)
+                         (let-values ([(gx gp gi) ((first gs) i)])
+                           (loop (rest gs) (list* gx xs) (list* gp ps) gi))))])
+      (values (apply append fx gs-x)
+              (lambda (env)
+                (let ([fe (fp env)]
+                      [gs-e (map (lambda (g) (g env)) gs-p)])
+                  (apply fe gs-e)))
+              gs-i))))
+
+(define (xml x)
+  (lambda (i)
+    (values (list x) (const id) i)))
+
+(define (xml-forest x)
+  (lambda (i)
+    (values x (const id) i)))
+
+(define (text x)
+  (xml x))
+
+(define (tag-xexpr t ats f)
+  (lambda (i)
+    (let-values ([(x p i) (f i)])
+      (values (list (list* t ats x))  p i))))
+
+(define (next-name i)
+  (values (format "input_~a" i) (add1 i)))
+(define (input i)
+  (let-values ([(w i) (next-name i)])
+    (values (list `(input ([name ,w])))
+            (lambda (env) (bindings-assq (string->bytes/utf-8 w) env))
+            i)))
+
+; Helpers
+(define (formlet-display f)
+  (let-values ([(x p i) (f 0)])
+    x))
+
+(define (formlet-process f r)
+  (let-values ([(x p i) (f 0)])
+    (p (request-bindings/raw r))))
+
+; Input Formlets
+(define input-string
+  (cross 
+   (pure (lambda (bf)
+           (bytes->string/utf-8 (binding:form-value bf))))
+   input))
+         
+(define input-int
+  (cross
+   (pure string->number)
+   input-string))
+
+(define input-symbol
+  (cross
+   (pure string->symbol)
+   input-string))
+
+; Contracts
+(define xexpr-forest/c
+  (listof xexpr?))
+
+(define (formlet/c c)
+  (integer? . -> . 
+            (values xexpr-forest/c
+                    ((listof binding?) . -> . (coerce-contract 'formlet/c c))
+                    integer?)))
+
+(define alpha any/c)
+(define beta any/c)
+
+(provide/contract
+ [formlet/c (any/c . -> . contract?)]
+ [pure (alpha
+        . -> . (formlet/c alpha))]
+ [cross ((formlet/c (alpha . -> . beta))
+         (formlet/c alpha)
+         . -> . (formlet/c beta))]
+ [cross* (((formlet/c (() () #:rest (listof alpha) . ->* . beta)))
+          () #:rest (listof (formlet/c alpha))
+          . ->* . (formlet/c beta))]
+ [xml (xexpr? . -> . (formlet/c procedure?))]
+ [xml-forest (xexpr-forest/c . -> . (formlet/c procedure?))]
+ [text (string? . -> . (formlet/c procedure?))]
+ [tag-xexpr (symbol? (listof (list/c symbol? string?)) (formlet/c alpha) . -> . (formlet/c alpha))]
+ [input-string (formlet/c string?)]
+ [input-int (formlet/c integer?)]
+ [input-symbol (formlet/c symbol?)]
+ [formlet-display ((formlet/c alpha) . -> . xexpr-forest/c)]
+ [formlet-process ((formlet/c alpha) request? . -> . alpha)])

collects/web-server/formlets/servlet.ss

@@ -0,0 +1,24 @@
+#lang scheme
+(require web-server/servlet
+         xml
+         "lib.ss")
+
+(provide/contract
+ [send/formlet ((formlet/c any/c) . -> . any/c)])
+
+(define (send/formlet f)
+  (formlet-process 
+   f
+   (send/suspend
+    (lambda (k-url)
+      `(form ([action ,k-url])
+             ,@(formlet-display f))))))
+
+(provide/contract
+ [embed-formlet (embed/url/c (formlet/c any/c) . -> . xexpr?)])
+
+(define (embed-formlet embed/url f)
+  `(form ([action ,(embed/url
+                    (lambda (r)
+                      (formlet-process f r)))])
+         ,@(formlet-display f)))