362 lines
12 KiB
Racket
362 lines
12 KiB
Racket
#lang racket
|
|
(require web-server/http
|
|
web-server/private/xexpr
|
|
(only-in "lib.rkt"
|
|
formlet/c
|
|
pure
|
|
cross))
|
|
|
|
; 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)])
|
|
(values (list (render w))
|
|
(lambda (env) (bindings-assq (string->bytes/utf-8 w) env))
|
|
i))))
|
|
|
|
(define binding:form-required
|
|
(pure
|
|
(lambda (bf)
|
|
(if (binding:form? bf)
|
|
(binding:form-value bf)
|
|
(error 'formlets "Missing required field")))))
|
|
|
|
(define (binding:form/default default)
|
|
(pure
|
|
(lambda (bf)
|
|
(if (binding:form? bf)
|
|
(binding:form-value bf)
|
|
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?)))])
|
|
|
|
; HTML Spec
|
|
(define (input
|
|
#:type [type "text"]
|
|
#:value [value #f]
|
|
#:size [size #f]
|
|
#:max-length [max-length #f]
|
|
#:read-only? [read-only? #f]
|
|
#:attributes [attrs empty])
|
|
(make-input
|
|
(lambda (n)
|
|
(list 'input
|
|
(list* (list 'name n)
|
|
(list 'type type)
|
|
(append
|
|
(filter list?
|
|
(list (and value (list 'value (bytes->string/utf-8 value)))
|
|
(and size (list 'size (number->string size)))
|
|
(and max-length (list 'maxlength (number->string max-length)))
|
|
(and read-only? (list 'readonly "true"))))
|
|
attrs))))))
|
|
|
|
(define (text-input
|
|
#:value [value #f]
|
|
#:size [size #f]
|
|
#:max-length [max-length #f]
|
|
#:read-only? [read-only? #f]
|
|
#:attributes [attrs empty])
|
|
(input
|
|
#:type "text"
|
|
#:value value
|
|
#:size size
|
|
#:max-length max-length
|
|
#:read-only? read-only?
|
|
#:attributes attrs))
|
|
|
|
(define (password-input
|
|
#:value [value #f]
|
|
#:size [size #f]
|
|
#:max-length [max-length #f]
|
|
#:read-only? [read-only? #f]
|
|
#:attributes [attrs empty])
|
|
(input
|
|
#:type "password"
|
|
#:value value
|
|
#:size size
|
|
#:max-length max-length
|
|
#:read-only? read-only?
|
|
#:attributes attrs))
|
|
|
|
(define (checkbox value checked?
|
|
#:attributes [attrs empty])
|
|
(input
|
|
#:type "checkbox"
|
|
#:value value
|
|
#:attributes
|
|
(if checked? (append (list (list 'checked "true")) attrs) attrs)))
|
|
|
|
(define (radio value checked?
|
|
#:attributes [attrs empty])
|
|
(input
|
|
#:type "radio"
|
|
#:attributes
|
|
(if checked? (append (list (list 'checked "true")) attrs) attrs)))
|
|
|
|
(define (submit value
|
|
#:attributes [attrs empty])
|
|
(input
|
|
#:type "submit"
|
|
#:value value
|
|
#:attributes attrs))
|
|
|
|
(define (reset value
|
|
#:attributes [attrs empty])
|
|
(input
|
|
#:type "reset"
|
|
#:value value
|
|
#:attributes attrs))
|
|
|
|
(define (file-upload #:attributes [attrs empty])
|
|
(input
|
|
#:type "file"
|
|
#:attributes attrs))
|
|
|
|
(define (hidden value #:attributes [attrs empty])
|
|
(input
|
|
#:type "hidden"
|
|
#:value value
|
|
#:attributes attrs))
|
|
|
|
(define (button type text
|
|
#:disabled [disabled #f]
|
|
#:value [value #f]
|
|
#:attributes [attrs empty])
|
|
(make-input
|
|
(λ (n)
|
|
(list 'button
|
|
(list* (list 'name n)
|
|
(list 'type (bytes->string/utf-8 type))
|
|
(append
|
|
(filter list?
|
|
(list (and disabled (list 'disabled (if disabled "true" "false")))
|
|
(and value (list 'value (bytes->string/utf-8 value)))))
|
|
attrs))
|
|
(bytes->string/utf-8 text)))))
|
|
|
|
(define (img alt src
|
|
#:height [height #f]
|
|
#:longdesc [ldesc #f]
|
|
#:usemap [map #f]
|
|
#:width [width #f]
|
|
#:attributes [attrs empty])
|
|
(make-input
|
|
(λ (n)
|
|
(list 'img
|
|
(list* (list 'name n)
|
|
(list 'src (bytes->string/utf-8 src))
|
|
(list 'alt (bytes->string/utf-8 alt))
|
|
(append
|
|
(filter list?
|
|
(list (and height (list 'height (number->string height)))
|
|
(and ldesc (list 'longdesc (bytes->string/utf-8 ldesc)))
|
|
(and map (list 'usemap (bytes->string/utf-8 map)))
|
|
(and width (list 'width (number->string width)))))
|
|
attrs))))))
|
|
|
|
(define (multiselect-input l
|
|
#:attributes [attrs empty]
|
|
#: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]
|
|
,@attrs)
|
|
,@(for/list ([vn (in-range i)])
|
|
(define e (hash-ref value->element vn))
|
|
(define v (number->string vn))
|
|
`(option ([value ,v]
|
|
,@(if (selected? e)
|
|
'([selected "true"])
|
|
empty))
|
|
,(display e))))))))
|
|
|
|
(define (select-input l
|
|
#:attributes [attrs empty]
|
|
#:selected? [selected? (λ (x) #f)]
|
|
#:display [display (λ (x) x)])
|
|
(cross
|
|
(pure first)
|
|
(multiselect-input l
|
|
#:attributes attrs
|
|
#:multiple? #f
|
|
#:selected? selected?
|
|
#:display display)))
|
|
|
|
(define (textarea-input
|
|
#:value [value #f]
|
|
#:attributes [attrs empty]
|
|
#:rows [rows #f]
|
|
#:cols [cols #f])
|
|
(make-input
|
|
(lambda (n)
|
|
(list 'textarea
|
|
(list* (list 'name n)
|
|
(append
|
|
(filter list?
|
|
(list (and rows (list 'rows (number->string rows)))
|
|
(and cols (list 'cols (number->string cols)))))
|
|
attrs))
|
|
(if value
|
|
(bytes->string/utf-8 value)
|
|
"")))))
|
|
|
|
(provide/contract
|
|
[text-input (()
|
|
(#:value (or/c false/c bytes?)
|
|
#:size (or/c false/c exact-nonnegative-integer?)
|
|
#:max-length (or/c false/c exact-nonnegative-integer?)
|
|
#:read-only? boolean?
|
|
#:attributes (listof (list/c symbol? string?)))
|
|
. ->* .
|
|
(formlet/c (or/c false/c binding?)))]
|
|
[password-input (()
|
|
(#:value (or/c false/c bytes?)
|
|
#:size (or/c false/c exact-nonnegative-integer?)
|
|
#:max-length (or/c false/c exact-nonnegative-integer?)
|
|
#:read-only? boolean?
|
|
#:attributes (listof (list/c symbol? string?)))
|
|
. ->* .
|
|
(formlet/c (or/c false/c binding?)))]
|
|
[checkbox ((bytes? boolean?)
|
|
(#:attributes (listof (list/c symbol? string?)))
|
|
. ->* .
|
|
(formlet/c (or/c false/c binding?)))]
|
|
[radio ((bytes? boolean?)
|
|
(#:attributes (listof (list/c symbol? string?)))
|
|
. ->* .
|
|
(formlet/c (or/c false/c binding?)))]
|
|
[submit ((bytes?)
|
|
(#:attributes (listof (list/c symbol? string?)))
|
|
. ->* .
|
|
(formlet/c (or/c false/c binding?)))]
|
|
[reset ((bytes?)
|
|
(#:attributes (listof (list/c symbol? string?)))
|
|
. ->* .
|
|
(formlet/c (or/c false/c binding?)))]
|
|
[file-upload (()
|
|
(#:attributes (listof (list/c symbol? string?)))
|
|
. ->* .
|
|
(formlet/c (or/c false/c binding?)))]
|
|
[hidden ((bytes?)
|
|
(#:attributes (listof (list/c symbol? string?)))
|
|
. ->* .
|
|
(formlet/c (or/c false/c binding?)))]
|
|
[img ((bytes? bytes?)
|
|
(#:height (or/c false/c exact-nonnegative-integer?)
|
|
#:longdesc (or/c false/c bytes?)
|
|
#:usemap (or/c false/c bytes?)
|
|
#:width (or/c false/c exact-nonnegative-integer?)
|
|
#:attributes (listof (list/c symbol? string?)))
|
|
. ->* .
|
|
(formlet/c (or/c false/c binding?)))]
|
|
[button ((bytes? bytes?)
|
|
(#:disabled
|
|
boolean?
|
|
#:value (or/c false/c bytes?)
|
|
#:attributes (listof (list/c symbol? string?)))
|
|
. ->* .
|
|
(formlet/c (or/c false/c binding?)))]
|
|
[multiselect-input ((sequence?)
|
|
(#:attributes
|
|
(listof (list/c symbol? string?))
|
|
#:multiple? boolean?
|
|
#:selected? (any/c . -> . boolean?)
|
|
#:display (any/c . -> . pretty-xexpr/c))
|
|
. ->* .
|
|
(formlet/c (listof any/c)))]
|
|
[select-input ((sequence?)
|
|
(#:attributes
|
|
(listof (list/c symbol? string?))
|
|
#:selected? (any/c . -> . boolean?)
|
|
#:display (any/c . -> . pretty-xexpr/c))
|
|
. ->* .
|
|
(formlet/c any/c))]
|
|
[textarea-input (()
|
|
(#:attributes
|
|
(listof (list/c symbol? string?))
|
|
#:value (or/c false/c bytes?)
|
|
#:rows number?
|
|
#:cols number?)
|
|
. ->* .
|
|
(formlet/c (or/c false/c binding?)))])
|
|
|
|
; High-level
|
|
(define (required f)
|
|
(cross binding:form-required f))
|
|
|
|
(define (default d f)
|
|
(cross (binding:form/default d) f))
|
|
|
|
(define (to-string f)
|
|
(cross (pure bytes->string/utf-8) f))
|
|
|
|
(define (to-number f)
|
|
(cross (pure string->number) f))
|
|
|
|
(define (to-symbol f)
|
|
(cross (pure string->symbol) f))
|
|
|
|
(define (to-boolean f)
|
|
(cross (pure
|
|
(lambda (b)
|
|
(bytes=? b #"on")))
|
|
f))
|
|
|
|
(provide/contract
|
|
[required ((formlet/c (or/c false/c binding?)) . -> . (formlet/c bytes?))]
|
|
[default (bytes? (formlet/c (or/c false/c binding?)) . -> . (formlet/c bytes?))]
|
|
[to-string ((formlet/c bytes?) . -> . (formlet/c string?))]
|
|
[to-number ((formlet/c string?) . -> . (formlet/c number?))]
|
|
[to-symbol ((formlet/c string?) . -> . (formlet/c symbol?))]
|
|
[to-boolean ((formlet/c bytes?) . -> . (formlet/c boolean?))])
|
|
|
|
; OLD
|
|
(define input-string (to-string (required (text-input))))
|
|
(define input-int (to-number input-string))
|
|
(define input-symbol (to-symbol input-string))
|
|
|
|
(provide/contract
|
|
[input-string (formlet/c string?)]
|
|
[input-int (formlet/c integer?)]
|
|
[input-symbol (formlet/c symbol?)])
|