! Redesign of input-fields.
+ Split input-fields into two structures:
+ surflets/my-input-fields allows you to create your own input-fields.
(complete with structure surflets/input-field-value)
+ surflets/surflet-input-fields are the proposals for input-fields
from SUrflets. They support annotated input-fields where
appropriate (select, radio, checkbox, hidden) and changing of attributes,
e.g. default values. See test.scm for examples.
The interface of the structure SURFLETS has only changed slightly
concerning the input fields
(make-higher-input-field --> make-multi-input-field should be the
main change)
+ Adapt examples to new input-field interface
+ Note new structures in documentation.
This commit is contained in:
interp
parent
6d64530779
commit
aa6e6aabfc
|
|
@ -5,248 +5,140 @@
|
|||
;;; input-fields
|
||||
;;; defines input-fields for surflets
|
||||
|
||||
;;; Globals
|
||||
(define *input-field-trigger* `*input-field*)
|
||||
(define generate-input-field-name generate-unique-name)
|
||||
|
||||
;; GET-BINDINGS?: Transformer will get all bindings of request, not
|
||||
;; only the one concerning the input-field.
|
||||
(define-record-type input-field :input-field
|
||||
(real-make-input-field name transformer html-tree get-bindings?)
|
||||
;;; Data structure for real-input-field
|
||||
;; MULTI?: Transformer will get all bindings of request, not only the
|
||||
;; one concerning the input-field.
|
||||
(define-record-type real-input-field :real-input-field
|
||||
(make-real-input-field name type transformer
|
||||
attributes html-tree-maker
|
||||
html-tree multi?)
|
||||
real-input-field?
|
||||
(name input-field-name)
|
||||
(transformer input-field-transformer)
|
||||
(attributes input-field-attributes)
|
||||
(html-tree input-field-html-tree)
|
||||
(get-bindings? input-field-get-bindings?))
|
||||
(name real-input-field-name)
|
||||
(type real-input-field-type)
|
||||
(transformer real-input-field-transformer)
|
||||
(attributes real-input-field-attributes set-real-input-field-attributes!)
|
||||
(html-tree-maker real-input-field-html-tree-maker)
|
||||
(html-tree real-input-field-html-tree set-real-input-field-html-tree!)
|
||||
(multi? real-input-field-multi?))
|
||||
|
||||
(define-record-discloser :input-field
|
||||
(define-record-discloser :real-input-field
|
||||
(lambda (input-field)
|
||||
(list 'input-field
|
||||
(input-field-name input-field))))
|
||||
(list 'real-input-field
|
||||
(real-input-field-type input-field)
|
||||
(real-input-field-name input-field))))
|
||||
|
||||
(define-syntax with-real-input-field
|
||||
(lambda (expr rename compare)
|
||||
(let ((%if (rename 'if))
|
||||
(%let (rename 'let))
|
||||
(%cadr (rename 'cadr))
|
||||
(%input-field? (rename 'input-field?))
|
||||
(%error (rename 'error))
|
||||
(input-field (cadr expr))
|
||||
(body (cddr expr)))
|
||||
`(,%if (,%input-field? ,input-field)
|
||||
(,%let ((real-input-field (,%cadr ,input-field)))
|
||||
,@body)
|
||||
(,%error "Invalid argument. Function wants an input-field."
|
||||
,input-field)))))
|
||||
|
||||
|
||||
;;; Fake input-field record. This is necessary, as the trigger in SXML
|
||||
;;; may only be symbols, not arbitrary values. Thus, our input-fields
|
||||
;;; must be preceeded by a trigger symbol to get recognized by the
|
||||
;;; SXML transforming routines like sxml->html.
|
||||
|
||||
;; Constructors: make-input-field, make-multi-input-field
|
||||
|
||||
;; Predicates: input-field?
|
||||
|
||||
;; Selectors: input-field-name, input-field-type,
|
||||
;; input-field-transformer, input-field-attributes,
|
||||
;; input-field-html-tree-maker, input-field-html-tree,
|
||||
;; input-field-multi?
|
||||
|
||||
;; Mutators: set-input-field-attributes!, touch-input-field!
|
||||
|
||||
;;; Constructors for input-field / multi-input-field
|
||||
(define (make-input-field name type transformer attributes
|
||||
html-tree-maker)
|
||||
(make-sxml-input-field
|
||||
(make-real-input-field name type transformer
|
||||
attributes html-tree-maker #f #f)))
|
||||
|
||||
(define (make-multi-input-field name type transformer attributes
|
||||
html-tree-maker)
|
||||
(make-sxml-input-field
|
||||
(make-real-input-field name type transformer
|
||||
attributes html-tree-maker #f #t)))
|
||||
|
||||
(define (make-sxml-input-field real-input-field)
|
||||
(list *input-field-trigger* real-input-field))
|
||||
|
||||
;; Have to do a trick to get around with SSAX: input-field is a list
|
||||
;; whose first element is *input-field-trigger* and the last (next) one
|
||||
;; is a real input-field.
|
||||
(define (input-field? input-field)
|
||||
(and (pair? input-field)
|
||||
(eq? *input-field-trigger* (car input-field))
|
||||
(real-input-field? (cadr input-field))))
|
||||
|
||||
(define generate-input-field-name generate-unique-name)
|
||||
|
||||
(define identity (lambda (a) a))
|
||||
(define (make-input-field-selector selector)
|
||||
(lambda (input-field)
|
||||
(with-real-input-field input-field
|
||||
(selector real-input-field))))
|
||||
|
||||
;; See note at input-field? for reasons for the list.
|
||||
(define (make-input-field name transformer html-tree)
|
||||
(list *input-field-trigger*
|
||||
(real-make-input-field name transformer html-tree #f)))
|
||||
(define (make-input-field-setter setter . maybe-reset?)
|
||||
(let ((reset? (:optional maybe-reset? #f)))
|
||||
(lambda (input-field value)
|
||||
(with-real-input-field input-field
|
||||
(if reset?
|
||||
(set-real-input-field-html-tree! real-input-field #f))
|
||||
(setter real-input-field value)))))
|
||||
|
||||
(define (make-higher-input-field transformer html-tree)
|
||||
(list *input-field-trigger*
|
||||
(real-make-input-field #f transformer html-tree #t)))
|
||||
|
||||
(define (make-text-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "text")))
|
||||
(optionals maybe-further-attributes
|
||||
((default-text string?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-input-field name
|
||||
identity
|
||||
`(input (@ (type "text")
|
||||
(name ,name)
|
||||
,(and default-text `(value ,default-text))
|
||||
;; this will insert a list, but
|
||||
;; XML->HTML doesn't care about it
|
||||
,(and attributes (cdr attributes))
|
||||
))))))
|
||||
|
||||
(define make-number-input-field
|
||||
(let ((number-input-field-transformer
|
||||
(lambda (string)
|
||||
(or (string->number string)
|
||||
(error "wrong type")))
|
||||
))
|
||||
(lambda maybe-further-attributes
|
||||
(let ((name (generate-input-field-name "number")))
|
||||
(optionals maybe-further-attributes
|
||||
((default (lambda (a) (or (number? a)
|
||||
(string-or-symbol? a))))
|
||||
(attributes sxml-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
number-input-field-transformer
|
||||
`(input (@ (type "text")
|
||||
(name ,name)
|
||||
,(and default `(value ,default))
|
||||
,(and attributes (cdr attributes))))))))))
|
||||
|
||||
(define (make-password-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "password")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes sxml-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
identity
|
||||
`(input (@ (type "password")
|
||||
(name ,name)
|
||||
,(and attributes (cdr attributes))))))))
|
||||
|
||||
(define (make-textarea-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "textarea")))
|
||||
(optionals maybe-further-attributes
|
||||
((default-text string?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
identity
|
||||
`(textarea (@ (type "textarea")
|
||||
(name ,name)
|
||||
,(and attributes (cdr attributes)))
|
||||
,(and default-text))))))
|
||||
|
||||
;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi"))))
|
||||
;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
|
||||
;; dropdown: (size 1)
|
||||
;; multiple choice: (multiple)
|
||||
;; preselected option: (selected)
|
||||
;; changed return value: (value new-value)
|
||||
;; returns a select input field with several options
|
||||
(define make-select-input-field
|
||||
(let ((make-multiple-transformer
|
||||
(lambda (name)
|
||||
(lambda (bindings)
|
||||
(map cdr
|
||||
(filter (lambda (binding)
|
||||
(equal? (car binding) name))
|
||||
bindings))))))
|
||||
|
||||
(lambda (options . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((multiple? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(let* ((name (generate-input-field-name "select"))
|
||||
(sxml-options
|
||||
(map (lambda (option)
|
||||
(define input-field-name (make-input-field-selector real-input-field-name))
|
||||
(define input-field-type (make-input-field-selector real-input-field-type))
|
||||
(define input-field-transformer
|
||||
(make-input-field-selector real-input-field-transformer))
|
||||
(define input-field-attributes
|
||||
(make-input-field-selector real-input-field-attributes))
|
||||
(define input-field-html-tree-maker
|
||||
(make-input-field-selector real-input-field-html-tree-maker))
|
||||
(define (input-field-html-tree input-field)
|
||||
(with-real-input-field input-field
|
||||
(cond
|
||||
((string-or-symbol? option)
|
||||
(list 'option option))
|
||||
((list? option)
|
||||
(cond
|
||||
((null? (cdr option))
|
||||
`(option ,option))
|
||||
((sxml-attribute? (cdr option)) ; w/attribs?
|
||||
`(option ,(cdr option) ,(car option)))
|
||||
((real-input-field-html-tree real-input-field)
|
||||
=> identity)
|
||||
(else
|
||||
(error "not an attribute" (cdr option)))))
|
||||
(else
|
||||
(error "not an option" option))))
|
||||
options))
|
||||
(sxml `(select (@ ((name ,name)
|
||||
,(if multiple? '(multiple) '())
|
||||
,(and attributes (cdr attributes))))
|
||||
#\newline
|
||||
,sxml-options)))
|
||||
(if multiple?
|
||||
(make-higher-input-field (make-multiple-transformer name) sxml)
|
||||
(make-input-field name identity sxml)))))))
|
||||
(let ((html-tree ((real-input-field-html-tree-maker real-input-field)
|
||||
input-field)))
|
||||
(set-real-input-field-html-tree! real-input-field html-tree)
|
||||
html-tree)))))
|
||||
|
||||
;; returns a *list* of radio buttons
|
||||
(define (make-radio-input-fields values . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "radio")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes sxml-attribute?))
|
||||
(map (lambda (value)
|
||||
(let ((value-value (if (pair? value) (car value) value))
|
||||
(value-attributes (if (pair? value)
|
||||
(if (sxml-attribute? (cdr value))
|
||||
(cddr value)
|
||||
(error "not an attribute" cdr value))
|
||||
#f)))
|
||||
(make-input-field
|
||||
name
|
||||
(lambda (select)
|
||||
select)
|
||||
`(input (@ ((type "radio")
|
||||
(name ,name)
|
||||
(value ,value-value)
|
||||
,(and value-attributes)
|
||||
,(and attributes (cdr attributes))))))))
|
||||
values))))
|
||||
(define input-field-multi?
|
||||
(make-input-field-selector real-input-field-multi?))
|
||||
|
||||
;; returns a checkbox input field
|
||||
(define (make-checkbox-input-field . maybe-further-attributes)
|
||||
(let* ((name (generate-input-field-name "checkbox")))
|
||||
(optionals maybe-further-attributes
|
||||
((checked? boolean?)
|
||||
(value (lambda (a) (or (string? a)
|
||||
(number? a)
|
||||
(symbol? a))))
|
||||
(attributes sxml-attribute?))
|
||||
(make-input-field
|
||||
name
|
||||
(lambda (value)
|
||||
(or (string=? value "on")
|
||||
value))
|
||||
`(input (@ ((type "checkbox")
|
||||
(name ,name)
|
||||
,(if value `(value ,value) '())
|
||||
,(if checked? '(checked) '())
|
||||
,(and attributes (cdr attributes)))))))))
|
||||
(define set-input-field-attributes! (make-input-field-setter set-real-input-field-attributes! #t))
|
||||
;; not exported:
|
||||
(define set-input-field-html-tree! (make-input-field-setter set-real-input-field-html-tree!))
|
||||
|
||||
|
||||
(define (make-hidden-input-field value . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "hidden")))
|
||||
(optionals maybe-further-attributes
|
||||
((attributes sxml-attribute?))
|
||||
(make-input-field name
|
||||
identity
|
||||
`(input (@ (type "hidden")
|
||||
(name ,name)
|
||||
(value ,value)
|
||||
,(and attributes (cdr attributes))))))))
|
||||
|
||||
(define (make-button type name button-caption attributes)
|
||||
(make-input-field name
|
||||
identity
|
||||
`(input (@ (type ,type)
|
||||
(name ,name)
|
||||
,(and button-caption `(value ,button-caption))
|
||||
,(and attributes (cdr attributes))))))
|
||||
|
||||
(define (string-or-symbol? a)
|
||||
(or (string? a)
|
||||
(symbol? a)))
|
||||
|
||||
(define (make-submit-button . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((button-caption string-or-symbol?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-button "submit" (generate-input-field-name "submit")
|
||||
button-caption attributes)))
|
||||
|
||||
(define (make-reset-button . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((button-caption string-or-symbol?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-button "reset" (generate-input-field-name "reset")
|
||||
button-caption attributes)))
|
||||
|
||||
(define (make-image-button image-source . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((attributes sxml-attribute?))
|
||||
(make-button "image" (generate-input-field-name "imgbtn")
|
||||
#f `(@ (src ,image-source)
|
||||
,@(if attributes (cdr attributes) '())))))
|
||||
;; A touched input-field's html-tree will be recalculated if
|
||||
;; neccessary.
|
||||
(define (touch-input-field! input-field)
|
||||
(set-input-field-html-tree! input-field #f))
|
||||
|
||||
;; <input-field>: '(input-field . <real-input-field>)
|
||||
;; <real-input-field>: #{Input-field "name"}
|
||||
;; <real-input-field>: #{Real-input-field "name"}
|
||||
(define (raw-input-field-value input-field bindings)
|
||||
(let ((input-field (cadr input-field)))
|
||||
(let ((real-input-field (cadr input-field)))
|
||||
(cond
|
||||
((input-field-get-bindings? input-field)
|
||||
((input-field-transformer input-field) bindings))
|
||||
((real-input-field-binding input-field bindings) =>
|
||||
((real-input-field-multi? real-input-field)
|
||||
((real-input-field-transformer real-input-field) bindings))
|
||||
((real-input-field-binding real-input-field bindings) =>
|
||||
(lambda (binding)
|
||||
((input-field-transformer input-field) (cdr binding))))
|
||||
((real-input-field-transformer real-input-field) (cdr binding))))
|
||||
(else
|
||||
(error "no such input-field" input-field bindings)))))
|
||||
|
||||
|
|
@ -263,12 +155,15 @@
|
|||
(let ((default (:optional maybe-default #f)))
|
||||
(with-fatal-error-handler
|
||||
(lambda (condition more)
|
||||
; (format #t "hit error condition: ~s~%" condition)
|
||||
default)
|
||||
(raw-input-field-value input-field bindings))))
|
||||
|
||||
(define (real-input-field-binding input-field bindings)
|
||||
(assoc (input-field-name input-field) bindings))
|
||||
(assoc (real-input-field-name input-field) bindings))
|
||||
|
||||
(define (input-field-binding input-field bindings)
|
||||
(real-input-field-binding (cadr input-field) bindings))
|
||||
|
||||
|
||||
;;EOF
|
||||
|
|
@ -64,6 +64,7 @@
|
|||
sxml->string
|
||||
sxml->string/internal
|
||||
sxml-attribute?
|
||||
sxml-attribute-attributes
|
||||
default-rule
|
||||
text-rule
|
||||
attribute-rule))
|
||||
|
|
@ -75,6 +76,7 @@
|
|||
surflet-form-rule
|
||||
default-rules
|
||||
plain-html-rule
|
||||
nbsp-rule
|
||||
url-rule))
|
||||
|
||||
;; Use for advanced users: make your own conversion rules.
|
||||
|
|
@ -100,8 +102,8 @@
|
|||
set-session-data!))
|
||||
|
||||
;; Use for advanced users: access to your sessions and continuations
|
||||
;; and continuations (currently you get access to all sessions; this
|
||||
;; should and will be restricted in the future)
|
||||
;; (currently you get access to all sessions; this should and will be
|
||||
;; restricted in the future)
|
||||
(define-interface surflets/my-sessions-interface
|
||||
(compound-interface
|
||||
surflets/ids-interface
|
||||
|
|
@ -274,41 +276,82 @@
|
|||
(export typed-optionals
|
||||
(optionals :syntax)))
|
||||
|
||||
;; Input-fields as Scheme-Objects
|
||||
(define-interface surflets/input-field-value-interface
|
||||
(export input-field?
|
||||
raw-input-field-value
|
||||
input-field-value
|
||||
input-field-binding))
|
||||
|
||||
|
||||
;; Input-fields as Scheme objects
|
||||
(define-interface surflets/input-fields-interface
|
||||
(export generate-input-field-name
|
||||
;; For advanced users: creating your own input-fields
|
||||
(define-interface surflets/my-input-fields-interface
|
||||
(compound-interface
|
||||
surflets/input-field-value-interface
|
||||
(export *input-field-trigger*
|
||||
generate-input-field-name
|
||||
make-input-field
|
||||
make-higher-input-field
|
||||
make-text-input-field
|
||||
make-hidden-input-field
|
||||
make-password-input-field
|
||||
make-multi-input-field
|
||||
input-field-name
|
||||
input-field-type
|
||||
input-field-transformer
|
||||
input-field-attributes
|
||||
input-field-html-tree-maker
|
||||
input-field-html-tree
|
||||
input-field-multi?
|
||||
set-input-field-attributes!
|
||||
touch-input-field!)))
|
||||
|
||||
(define-interface surflets/surflet-input-fields-interface
|
||||
(compound-interface
|
||||
surflets/input-field-value-interface
|
||||
(export make-text-input-field
|
||||
set-text-input-field-value!
|
||||
|
||||
make-number-input-field
|
||||
set-number-input-field-value!
|
||||
|
||||
make-hidden-input-field
|
||||
set-hidden-input-field-value!
|
||||
|
||||
make-password-input-field
|
||||
set-password-input-field-value!
|
||||
|
||||
make-textarea-input-field
|
||||
set-textarea-input-field-value!
|
||||
|
||||
make-select-input-field
|
||||
make-checkbox-input-field
|
||||
make-annotated-select-input-field
|
||||
make-simple-sel-if-option
|
||||
make-annotated-sel-if-option
|
||||
sel-if-option?
|
||||
select-sel-if-option!
|
||||
unselect-sel-if-option!
|
||||
set-sel-if-option-selected?!
|
||||
|
||||
make-radio-input-field-group
|
||||
make-annotated-radio-input-field-group
|
||||
make-radio-input-fields
|
||||
check-radio-input-field!
|
||||
uncheck-radio-input-field!
|
||||
set-radio-input-field-checked?!
|
||||
|
||||
make-checkbox-input-field
|
||||
make-annotated-checkbox-input-field
|
||||
check-checkbox-input-field!
|
||||
uncheck-checkbox-input-field!
|
||||
set-checkbox-input-field-checked?!
|
||||
|
||||
make-submit-button
|
||||
make-reset-button
|
||||
make-image-button
|
||||
input-field-value
|
||||
raw-input-field-value
|
||||
input-field-binding
|
||||
input-field?))
|
||||
|
||||
;;; This is for surflets/surflet-sxml only:
|
||||
(define-interface surflets/input-fields/internal-interface
|
||||
(export *input-field-trigger*
|
||||
input-field-html-tree))
|
||||
make-image-button)))
|
||||
|
||||
;; Some utilities
|
||||
(define-interface surflets/utilities-interface
|
||||
(export form-query-list
|
||||
rev-append
|
||||
generate-unique-number
|
||||
generate-unique-name))
|
||||
generate-unique-name
|
||||
identity))
|
||||
|
||||
;; Intelligent Addresses
|
||||
(define-interface surflets/addresses-interface
|
||||
|
|
@ -358,7 +401,7 @@
|
|||
; surflets/sxml-interface
|
||||
; surflets/surflet-sxml-interface
|
||||
surflets/send-html-interface
|
||||
surflets/input-fields-interface
|
||||
surflets/surflet-input-fields-interface
|
||||
surflets/addresses-interface
|
||||
surflets/returned-via-interface
|
||||
surflets/bindings-interface
|
||||
|
|
@ -412,7 +455,7 @@
|
|||
(define-structure surflets surflets-interface
|
||||
(open surflets/session-data
|
||||
surflets/send-html ;send-html/suspend...
|
||||
surflets/input-fields
|
||||
surflets/surflet-input-fields
|
||||
surflets/addresses ;annotated-address...
|
||||
surflets/returned-via
|
||||
surflets/bindings))
|
||||
|
|
@ -460,6 +503,7 @@
|
|||
define-record-types
|
||||
let-opt
|
||||
surflets
|
||||
surflets/surflet-input-fields
|
||||
(subset srfi-1 (zip filter find make-list))
|
||||
handle-fatal-error
|
||||
)
|
||||
|
|
@ -511,26 +555,40 @@
|
|||
|
||||
;; Input fields as Scheme objects
|
||||
(define-structures
|
||||
((surflets/input-fields surflets/input-fields-interface)
|
||||
(surflets/input-fields/internal
|
||||
surflets/input-fields/internal-interface))
|
||||
(open scheme
|
||||
srfi-23 ;error
|
||||
(subset srfi-1 (filter))
|
||||
((surflets/input-field-value surflets/input-field-value-interface)
|
||||
(surflets/my-input-fields surflets/my-input-fields-interface))
|
||||
(open scheme-with-scsh ;error, format
|
||||
(subset let-opt (:optional))
|
||||
handle-fatal-error
|
||||
define-record-types
|
||||
(subset typed-optionals (optionals))
|
||||
surflets/sxml
|
||||
surflets/utilities ;rev-append,generate-unique-name
|
||||
surflets/utilities
|
||||
)
|
||||
(files input-fields))
|
||||
|
||||
(define-structure surlfets/input-fields surflets/my-input-fields)
|
||||
|
||||
(define-structure surflets/surflet-input-fields
|
||||
surflets/surflet-input-fields-interface
|
||||
(open scheme-with-scsh ;error, format
|
||||
;; avoid name collision for member
|
||||
(modify srfi-1 (rename (member member/srfi-1)))
|
||||
define-record-types
|
||||
(subset let-opt (:optional))
|
||||
(subset typed-optionals (optionals))
|
||||
surflets/my-input-fields
|
||||
surflets/utilities ;generate-unique-number
|
||||
surflets/sxml
|
||||
tables ;make-integer-table
|
||||
)
|
||||
(files surflet-input-fields))
|
||||
|
||||
|
||||
;; Extensions to SXML for surflets
|
||||
(define-structure surflets/surflet-sxml surflets/surflet-sxml-interface
|
||||
(open scheme-with-scsh ;error,receive
|
||||
surflets/input-fields/internal
|
||||
(subset surflets/my-input-fields
|
||||
(*input-field-trigger* input-field-html-tree))
|
||||
surflets/sxml
|
||||
typed-optionals
|
||||
(subset sxml-tree-trans (pre-post-order)))
|
||||
|
|
@ -578,7 +636,7 @@
|
|||
|
||||
(define-structure surflets/returned-via surflets/returned-via-interface
|
||||
(open scheme
|
||||
surflets/input-fields
|
||||
surflets/input-field-value
|
||||
surflets/addresses
|
||||
(subset uri (unescape-uri)))
|
||||
(files returned-via))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,472 @@
|
|||
;;; SUrflets' input fields
|
||||
;;; Copyright 2002, 2003 Andreas Bernauer
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Functions to create simple input fields
|
||||
|
||||
;; The interface for input-fields does not prescribe what the type of
|
||||
;; attributes has to be. We choose a record here.
|
||||
|
||||
(define-record-type input-field-attributes :input-field-attributes
|
||||
(make-input-field-attributes default others)
|
||||
input-field-attributes?
|
||||
(default input-field-attributes-default set-input-field-attributes-default!)
|
||||
(others input-field-attributes-others set-input-field-attributes-others!))
|
||||
|
||||
;; A simple input-field is a prototype for other input-fields.
|
||||
;; REPORTED-TYPE is the type of the input-field in HTML, TYPE the
|
||||
;; internal referenced type and TRANSFORMER the function that
|
||||
;; translates the HTTP-string of the request into a scheme value.
|
||||
(define (simple-input-field-maker reported-type type default-pred transformer)
|
||||
(lambda maybe-further-attributes
|
||||
(let ((name (generate-input-field-name type)))
|
||||
(optionals maybe-further-attributes
|
||||
((default default-pred)
|
||||
(attributes sxml-attribute?))
|
||||
(make-input-field name type
|
||||
transformer
|
||||
(make-input-field-attributes
|
||||
(and default `(value ,default))
|
||||
(sxml-attribute-attributes attributes))
|
||||
(simple-input-field-maker-html-tree-maker
|
||||
reported-type))))))
|
||||
|
||||
(define (simple-input-field-maker-html-tree-maker reported-type)
|
||||
(lambda (input-field)
|
||||
(let ((attributes (input-field-attributes input-field)))
|
||||
`(input (@ (type ,reported-type)
|
||||
(name ,(input-field-name input-field))
|
||||
,(input-field-attributes-default attributes)
|
||||
,(input-field-attributes-others attributes))))))
|
||||
|
||||
(define (make-simple-input-field-default-setter default-pred? wrap?)
|
||||
(lambda (input-field value)
|
||||
(if (default-pred? value)
|
||||
(set-input-field-attributes-default!
|
||||
(input-field-attributes input-field)
|
||||
(if wrap? `(value ,value) value))
|
||||
(error "Default value must be a number or a string or a symbol."
|
||||
value))
|
||||
(touch-input-field! input-field)))
|
||||
|
||||
(define (string-or-symbol? thing)
|
||||
(or (string? thing) (symbol? thing)))
|
||||
(define simple-default? string-or-symbol?)
|
||||
|
||||
(define set-simple-input-field-default!
|
||||
(make-simple-input-field-default-setter simple-default? #t))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Text input field
|
||||
(define make-text-input-field
|
||||
(simple-input-field-maker "text" "text"
|
||||
simple-default? identity))
|
||||
(define set-text-input-field-value! set-simple-input-field-default!)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Number input field
|
||||
(define (number-input-field-default? value)
|
||||
(or (number? value)
|
||||
(simple-default? value)))
|
||||
(define (number-input-field-transformer string)
|
||||
(or (string->number string)
|
||||
(error "wrong type")))
|
||||
(define make-number-input-field
|
||||
(simple-input-field-maker "text" "number"
|
||||
number-input-field-default?
|
||||
number-input-field-transformer))
|
||||
(define set-number-input-field-value!
|
||||
(make-simple-input-field-default-setter number-input-field-default? #t))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; hidden input-field
|
||||
;; Little workaraound, as a hidden input-field needs a value. This
|
||||
;; value is propagated in the slot "default value".
|
||||
(define make-hidden-input-field
|
||||
(let ((hidden-input-field-generator
|
||||
(simple-input-field-maker "hidden" "text"
|
||||
simple-default? identity)))
|
||||
(lambda (value . maybe-further-attributes)
|
||||
(apply hidden-input-field-generator
|
||||
(cons value maybe-further-attributes)))))
|
||||
(define set-hidden-input-field-value!
|
||||
set-simple-input-field-default!)
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Password input field
|
||||
(define make-password-input-field
|
||||
(simple-input-field-maker "password" "password"
|
||||
simple-default? identity))
|
||||
(define set-password-input-field-value!
|
||||
set-simple-input-field-default!)
|
||||
|
||||
;;; That's it for simple input fields.
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Textarea input field
|
||||
(define (make-textarea-input-field . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "textarea")))
|
||||
(optionals maybe-further-attributes
|
||||
((default-text simple-default?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-input-field
|
||||
name "textarea"
|
||||
identity
|
||||
(make-input-field-attributes
|
||||
(and default-text)
|
||||
(sxml-attribute-attributes attributes))
|
||||
make-textarea-input-field-html-tree))))
|
||||
|
||||
(define (make-textarea-input-field-html-tree input-field)
|
||||
(let ((attributes (input-field-attributes input-field)))
|
||||
`(textarea (@ (type "textarea")
|
||||
(name ,(input-field-name input-field))
|
||||
,(input-field-attributes-others attributes))
|
||||
,(input-field-attributes-default attributes))))
|
||||
|
||||
(define set-textarea-input-field-value!
|
||||
(let ((textarea-default-setter!
|
||||
(make-simple-input-field-default-setter simple-default? #f)))
|
||||
(lambda (textarea-input-field value)
|
||||
(textarea-default-setter! textarea-input-field value))))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Selection input field
|
||||
|
||||
;; sel-if == select-input-field
|
||||
;(make-select-input-fields '("this" "that" "those") '(@ ((id "sushi"))))
|
||||
;(make-select-input-fields '("this" ("that" '(@ (selected))) "those"))
|
||||
;; dropdown: (size 1)
|
||||
|
||||
;;; A selection input field shows a list of options that can be
|
||||
;;; selected. For this purpose, we introduce an sel-if-option record,
|
||||
;;; that contains all the information for each option. This is
|
||||
;;; justified by the fact, that the options list is in HTML seperated,
|
||||
;;; too.
|
||||
(define-record-type sel-if-option :sel-if-option
|
||||
(really-make-sel-if-option tag value selected? attributes)
|
||||
sel-if-option?
|
||||
(tag sel-if-option-tag)
|
||||
(value sel-if-option-value)
|
||||
(selected? sel-if-option-selected? set-sel-if-option-selected?!)
|
||||
(attributes sel-if-option-attributes set-sel-if-option-attributes!))
|
||||
|
||||
(define (make-sel-if-option tag value selected? attributes)
|
||||
(if (string? tag)
|
||||
(really-make-sel-if-option tag value selected?
|
||||
(sxml-attribute-attributes attributes))
|
||||
(error "Select-input-field-option's tag must be a string." tag)))
|
||||
|
||||
;; Constructor for valued select input-field option.
|
||||
(define (make-annotated-sel-if-option tag value . maybe-attributes)
|
||||
(optionals maybe-attributes
|
||||
((selected? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-sel-if-option tag value selected? attributes)))
|
||||
|
||||
;; Constructor for a simple select input-field option (not annotated).
|
||||
(define (make-simple-sel-if-option tag . maybe-attributes)
|
||||
(optionals maybe-attributes
|
||||
((selected? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-sel-if-option tag 'ignored selected? attributes)))
|
||||
|
||||
(define-record-discloser :sel-if-option
|
||||
(lambda (sel-if-option)
|
||||
(list 'select-input-field-option
|
||||
(sel-if-option-tag sel-if-option)
|
||||
(sel-if-option-value sel-if-option)
|
||||
(sel-if-option-selected? sel-if-option)
|
||||
(sel-if-option-attributes sel-if-option)
|
||||
)))
|
||||
|
||||
;; Selecting / Unselecting of an option in an select input-field,
|
||||
;; chosen by tag.
|
||||
(define (select-sel-if-option! tag sel-if)
|
||||
(set-select-input-field-option-selected?! tag sel-if #t))
|
||||
|
||||
(define (unselect-sel-if-option! tag sel-if)
|
||||
(set-select-input-field-option-selected?! tag sel-if #f))
|
||||
|
||||
(define (set-select-input-field-option-selected?! tag sel-if selected?)
|
||||
(let ((options (input-field-attributes-default
|
||||
(input-field-attributes sel-if))))
|
||||
(if (number? tag)
|
||||
(set-sel-if-option-selected?! (list-ref options tag)
|
||||
selected?)
|
||||
(let lp ((options options))
|
||||
(if (null? options)
|
||||
(error "No such option" tag sel-if)
|
||||
(if (tag=sel-if-option? tag (car options))
|
||||
(set-sel-if-option-selected?! (car options) selected?)
|
||||
(lp (cdr options))))))
|
||||
(touch-input-field! sel-if)))
|
||||
|
||||
;; Find sel-if-option in a list by its tag.
|
||||
(define (tag=sel-if-option? tag sel-if-option)
|
||||
(string=? tag (sel-if-option-tag sel-if-option)))
|
||||
|
||||
(define (find-sel-if-option tag sel-if-options)
|
||||
(cond ((member/srfi-1 tag sel-if-options tag=sel-if-option?)
|
||||
=> car)
|
||||
(else #f)))
|
||||
|
||||
(define (find-sel-if-option-value tag sel-if-options)
|
||||
(cond ((find-sel-if-option tag sel-if-options)
|
||||
=> sel-if-option-value)
|
||||
(else #f)))
|
||||
|
||||
;; To be compatible with previous versions of MAKE-SELECT-INPUT-FIELD,
|
||||
;; we accept also a simple list as an option-list. New programs should
|
||||
;; use sel-if-options-list (easily createable with
|
||||
;; (map make-simple-sel-if-option option-list))
|
||||
(define (tolerate-old-sel-if-options sel-if-options)
|
||||
(if (and (list? sel-if-options)
|
||||
(every sel-if-option? sel-if-options))
|
||||
sel-if-options
|
||||
(map make-simple-sel-if-option sel-if-options)))
|
||||
|
||||
(define (make-select-input-field sel-if-options . maybe-further-attributes)
|
||||
(really-make-select-input-field (tolerate-old-sel-if-options sel-if-options)
|
||||
#f
|
||||
maybe-further-attributes))
|
||||
|
||||
(define (make-annotated-select-input-field sel-if-options .
|
||||
maybe-further-attributes)
|
||||
(really-make-select-input-field sel-if-options #t maybe-further-attributes))
|
||||
|
||||
(define (really-make-select-input-field sel-if-options annotated?
|
||||
maybe-further-attributes)
|
||||
(let ((real-sel-if-options (tolerate-old-sel-if-options sel-if-options)))
|
||||
(optionals maybe-further-attributes
|
||||
((multiple? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(let ((name (generate-input-field-name "select")))
|
||||
(if multiple?
|
||||
(make-multiple-select-input-field name sel-if-options
|
||||
annotated? attributes)
|
||||
(make-single-select-input-field name sel-if-options
|
||||
annotated? attributes))))))
|
||||
|
||||
;; internal
|
||||
(define (make-multiple-select-input-field name sel-if-options
|
||||
annotated? attributes)
|
||||
(make-multi-input-field name "mult-select"
|
||||
(make-sel-if-multiple-transformer name sel-if-options
|
||||
annotated?)
|
||||
(make-input-field-attributes
|
||||
sel-if-options
|
||||
(list '(multiple)
|
||||
(sxml-attribute-attributes attributes)))
|
||||
make-sel-if-html-tree))
|
||||
|
||||
;; internal
|
||||
(define (make-single-select-input-field name sel-if-options
|
||||
annotated? attributes)
|
||||
(make-input-field name "select"
|
||||
(if annotated?
|
||||
(lambda (tag)
|
||||
(cond ((find-sel-if-option-value tag sel-if-options)
|
||||
=> identity)
|
||||
(else (error "no such option." tag))))
|
||||
identity)
|
||||
(make-input-field-attributes
|
||||
sel-if-options
|
||||
(sxml-attribute-attributes attributes))
|
||||
make-sel-if-html-tree))
|
||||
|
||||
(define (make-sel-if-multiple-transformer name sel-if-options annotated?)
|
||||
(lambda (bindings)
|
||||
(let ((tags (map cdr
|
||||
(filter (lambda (binding)
|
||||
(equal? (car binding) name))
|
||||
bindings))))
|
||||
(filter-map (if annotated?
|
||||
(lambda (tag)
|
||||
(find-sel-if-option-value tag sel-if-options))
|
||||
(lambda (tag)
|
||||
(if (find-sel-if-option tag sel-if-options)
|
||||
tag
|
||||
#f)))
|
||||
tags))))
|
||||
|
||||
(define (make-sel-if-html-tree sel-if)
|
||||
(let ((attributes (input-field-attributes sel-if)))
|
||||
`(select (@ (name ,(input-field-name sel-if))
|
||||
,(input-field-attributes-others attributes))
|
||||
#\newline
|
||||
,@(make-sel-if-options-html-tree
|
||||
(input-field-attributes-default attributes)))))
|
||||
|
||||
(define (make-sel-if-options-html-tree sel-if-options)
|
||||
(map (lambda (sel-if-option)
|
||||
`(option (@ ,(and (sel-if-option-selected? sel-if-option) '(selected))
|
||||
,(sel-if-option-attributes sel-if-option))
|
||||
,(sel-if-option-tag sel-if-option)))
|
||||
sel-if-options))
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; radio input-fields
|
||||
;; Because grouped radio input-fields must use the same name, we
|
||||
;; cannot just return one radio input-field object, but we must
|
||||
;; generate several ones with the same name.
|
||||
(define (make-radio-input-field-group)
|
||||
(let ((name (generate-input-field-name "radio")))
|
||||
(lambda (value-string . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((checked? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-input-field name "radio"
|
||||
identity
|
||||
(make-input-field-attributes
|
||||
(if checked? '(checked) #f)
|
||||
(list `(value ,value-string)
|
||||
(sxml-attribute-attributes attributes)))
|
||||
radio-input-field-html-tree-maker)))))
|
||||
|
||||
(define (make-annotated-radio-input-field-group)
|
||||
(let* ((name (generate-input-field-name "radio"))
|
||||
(value-table (make-integer-table))
|
||||
(transformer (make-radio-input-field-transformer value-table)))
|
||||
(lambda (value . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((checked? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(let ((number (generate-unique-number)))
|
||||
(table-set! value-table number value)
|
||||
(make-input-field name "radio"
|
||||
transformer
|
||||
(make-input-field-attributes
|
||||
(if checked? '(checked) #f)
|
||||
(list`(value ,(number->string number))
|
||||
(sxml-attribute-attributes attributes)))
|
||||
radio-input-field-html-tree-maker))))))
|
||||
|
||||
(define (make-radio-input-fields values . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((attributes sxml-attribute?))
|
||||
(let ((radio-gen (make-annotated-radio-input-field-group)))
|
||||
(map (lambda (value)
|
||||
(if attributes
|
||||
(radio-gen value attributes)
|
||||
(radio-gen value)))
|
||||
values))))
|
||||
|
||||
|
||||
(define (make-radio-input-field-transformer value-table)
|
||||
(lambda (tag)
|
||||
(cond
|
||||
((string->number tag) =>
|
||||
(lambda (number)
|
||||
(let ((value (table-ref value-table number)))
|
||||
(if value
|
||||
value
|
||||
(error "Unknown tag number for radio input-field" tag)))))
|
||||
(else
|
||||
(error "Unknown tag number for radio input-field" tag)))))
|
||||
|
||||
(define (radio-input-field-html-tree-maker radio-input-field)
|
||||
(let* ((attributes (input-field-attributes radio-input-field)))
|
||||
`(input (@ ((type "radio")
|
||||
(name ,(input-field-name radio-input-field))
|
||||
,(input-field-attributes-default attributes)
|
||||
,(input-field-attributes-others attributes))))))
|
||||
|
||||
(define (set-input-field-checked?! input-field checked?)
|
||||
(let ((attributes (input-field-attributes input-field)))
|
||||
(set-input-field-attributes-default!
|
||||
attributes
|
||||
(if checked? '(checked) #f))
|
||||
(touch-input-field! input-field)))
|
||||
|
||||
(define set-radio-input-field-checked?! set-input-field-checked?!)
|
||||
(define (check-radio-input-field! radio)
|
||||
(set-radio-input-field-checked?! radio #t))
|
||||
(define (uncheck-radio-input-field! radio)
|
||||
(set-radio-input-field-checked?! radio #f))
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; checkbox input-field
|
||||
(define (make-checkbox-input-field . maybe-further-attributes)
|
||||
(really-make-checkbox-input-field #t
|
||||
checkbox-transformer
|
||||
maybe-further-attributes))
|
||||
|
||||
(define (make-annotated-checkbox-input-field value . maybe-further-attributes)
|
||||
(really-make-checkbox-input-field value
|
||||
(make-checkbox-transformer value)
|
||||
maybe-further-attributes))
|
||||
|
||||
(define (really-make-checkbox-input-field value transformer attributes)
|
||||
(let ((name (generate-input-field-name "checkbox")))
|
||||
(optionals attributes
|
||||
((checked? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-input-field name "checkbox"
|
||||
transformer
|
||||
(make-input-field-attributes
|
||||
(if checked? '(checked) #f)
|
||||
(sxml-attribute-attributes attributes))
|
||||
checkbox-input-field-html-tree-maker))))
|
||||
|
||||
(define (make-checkbox-transformer value)
|
||||
(lambda (tag)
|
||||
(if (string=? tag "on")
|
||||
value
|
||||
#f)))
|
||||
|
||||
(define checkbox-transformer
|
||||
(make-checkbox-transformer #t))
|
||||
|
||||
(define (checkbox-input-field-html-tree-maker cb-if)
|
||||
(let ((attributes (input-field-attributes cb-if)))
|
||||
`(input (@ ((type "checkbox")
|
||||
(name ,(input-field-name cb-if))
|
||||
,(input-field-attributes-default attributes)
|
||||
,(input-field-attributes-others attributes))))))
|
||||
|
||||
(define set-checkbox-input-field-checked?! set-input-field-checked?!)
|
||||
(define (check-checkbox-input-field! checkbox)
|
||||
(set-checkbox-input-field-checked?! checkbox #t))
|
||||
(define (uncheck-checkbox-input-field! checkbox)
|
||||
(set-checkbox-input-field-checked?! checkbox #f))
|
||||
;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; button input-fields
|
||||
(define (make-button type name button-caption attributes)
|
||||
(make-input-field name type
|
||||
identity
|
||||
(make-input-field-attributes
|
||||
(and button-caption `(value ,button-caption))
|
||||
(sxml-attribute-attributes attributes))
|
||||
make-button-html-tree))
|
||||
|
||||
(define (make-button-html-tree button-input-field)
|
||||
(let ((attributes (input-field-attributes button-input-field)))
|
||||
`(input (@ (type ,(input-field-type button-input-field))
|
||||
(name ,(input-field-name button-input-field))
|
||||
,(input-field-attributes-default attributes)
|
||||
,(input-field-attributes-others attributes)))))
|
||||
|
||||
(define (make-submit-button . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((button-caption string?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-button "submit" (generate-input-field-name "submit")
|
||||
button-caption attributes)))
|
||||
|
||||
(define (make-reset-button . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((button-caption string?)
|
||||
(attributes sxml-attribute?))
|
||||
(make-button "reset" (generate-input-field-name "reset")
|
||||
button-caption attributes)))
|
||||
|
||||
(define (make-image-button image-source . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((attributes sxml-attribute?))
|
||||
(make-button "image" (generate-input-field-name "imgbtn")
|
||||
#f `(@ (src ,image-source)
|
||||
,@(sxml-attribute-attributes attributes)))))
|
||||
|
||||
|
||||
|
||||
;;EOF
|
||||
|
|
@ -3,7 +3,7 @@ We have three basic layers of structures: -*- Outline -*-
|
|||
* Overview
|
||||
(a) Basic User surflets, simple-surflet-api
|
||||
(b) Advanced User surflets/my-sxml, surflets/my-sessions,
|
||||
surflets/primitives
|
||||
surflets/my-input-fields, surflets/primitives
|
||||
(c) Administrative User surflet-handler/admin, profiling
|
||||
|
||||
The fourth layer:
|
||||
|
|
@ -17,12 +17,13 @@ own rules.
|
|||
provides: . sending of html represented by surflet-sxml
|
||||
. using special tags in its surflet-sxml:
|
||||
url, plain-html, surflet-form
|
||||
. input-fields, input-field-value,...
|
||||
. input-fields: input-field-value,
|
||||
input-field-binding, ...
|
||||
. get-bindings, extract-bindings, ...
|
||||
. make-address, make-annotated-address, ...
|
||||
. returned-via?, case-returned-via, ...
|
||||
. get-session-data, set-session-data!
|
||||
surflets is splitted in several parts, that can
|
||||
surflets contains of several parts, that can
|
||||
be loaded independently from each other.
|
||||
|
||||
** structures: (2) simple-surflet-api
|
||||
|
|
@ -57,7 +58,12 @@ own rules.
|
|||
. session-alive?, session-surflet-name
|
||||
. access to options: options-session-lifetime,
|
||||
options-cache-surflets?
|
||||
** structures: (3) surflet-handler/primitives
|
||||
|
||||
** structures: (3) surflets/my-input-fields
|
||||
provides: . Access to the primitives of input-fields:
|
||||
. Constructor, selector, mutators, predicate
|
||||
|
||||
** structures: (4) surflet-handler/primitives
|
||||
provides: . Access to the primitives of the
|
||||
surflet handler:
|
||||
. send/suspend, ... that send surflet responses
|
||||
|
|
@ -68,7 +74,6 @@ own rules.
|
|||
(string or list of strings)
|
||||
. surflet-requests...
|
||||
|
||||
|
||||
* (c) Administrative User
|
||||
** structures: (1) surflet-handler/admin
|
||||
provides: . Access to all internal structures of the
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
(define-structure surflet surflet-interface
|
||||
(open surflets
|
||||
surflet-requests
|
||||
surflets/my-input-fields
|
||||
handle-fatal-error
|
||||
url
|
||||
scheme-with-scsh)
|
||||
|
|
@ -16,20 +17,22 @@
|
|||
(if (= count bits)
|
||||
'()
|
||||
(cons
|
||||
(make-checkbox-input-field (number->string order))
|
||||
(make-annotated-checkbox-input-field order)
|
||||
(loop (+ 1 count)
|
||||
(* 2 order))))))))
|
||||
(make-higher-input-field
|
||||
(make-multi-input-field
|
||||
#f "byte-input"
|
||||
(lambda (bindings)
|
||||
(let loop ((sum 0)
|
||||
(checkboxes checkboxes))
|
||||
(if (null? checkboxes)
|
||||
sum
|
||||
(loop (+ sum (string->number
|
||||
(or (input-field-value (car checkboxes) bindings)
|
||||
"0")))
|
||||
(loop (+ sum (or (input-field-value (car checkboxes) bindings)
|
||||
0))
|
||||
(cdr checkboxes)))))
|
||||
checkboxes)))
|
||||
'()
|
||||
(lambda (ignore)
|
||||
checkboxes))))
|
||||
|
||||
(define byte-input-fields (make-byte-input-fields 8))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
(define-structure surflet surflet-interface
|
||||
(open surflets
|
||||
surflets/my-input-fields
|
||||
surflet-requests
|
||||
handle-fatal-error
|
||||
let-opt
|
||||
|
|
@ -20,17 +21,18 @@
|
|||
(define operator-input-field
|
||||
(let ((name (generate-input-field-name "operator")))
|
||||
(make-input-field
|
||||
name
|
||||
name "operator"
|
||||
(lambda (operator-string)
|
||||
(cond
|
||||
((assoc operator-string *operator-alist*) =>
|
||||
(lambda (a) a))
|
||||
(else
|
||||
(let ((operator (assoc operator-string *operator-alist*)))
|
||||
(if operator
|
||||
operator
|
||||
(error "no such operator" operator-string))))
|
||||
'()
|
||||
(lambda (input-field)
|
||||
`(select (@ (name ,name))
|
||||
,@(map (lambda (operator)
|
||||
`(option ,(operator-symbol operator)))
|
||||
*operator-alist*)))))
|
||||
*operator-alist*))))))
|
||||
|
||||
|
||||
(define (make-number-input-field/default default)
|
||||
|
|
|
|||
|
|
@ -163,9 +163,9 @@
|
|||
(and armed?
|
||||
(map (lambda (type)
|
||||
(let ((text (cdr (assoc type arm-types))))
|
||||
(cons (make-checkbox-input-field
|
||||
(and def-weapons (member? text def-weapons))
|
||||
text)
|
||||
(cons (make-annotated-checkbox-input-field
|
||||
text
|
||||
(and def-weapons (member? text def-weapons)))
|
||||
text)))
|
||||
(ship-data-arm-types (ship-ref class)))))
|
||||
(energy-input (and armed?
|
||||
|
|
@ -215,7 +215,7 @@
|
|||
;;; items are taken from the ship data list.
|
||||
(define (get-extras req class)
|
||||
(let* ((checkboxes+text (map (lambda (extra)
|
||||
(cons (make-checkbox-input-field extra)
|
||||
(cons (make-annotated-checkbox-input-field extra)
|
||||
(cdr (assoc extra extras))))
|
||||
(ship-data-extras (ship-ref class))))
|
||||
(req (send-html/suspend
|
||||
|
|
|
|||
Loading…
Reference in New Issue