Remove module typed-optionals. We don't need it anymore.
Rename function TYPED-OPTONALS to OPTIONALS-FIRST and move its definition to the only module that uses it: sxml.scm Use LET-OPTIONALS instead of OPTIONALS, as it does the job, too, and it ensures that the meaning of an argument depends only on its position and not on the amount of arguments in front of it. This commit removes a pitfall in calls to MAKE-TEXTAREA. Nearly every example SUrflet continues to work unchanged, except of one line in admin-surflets.scm, thus updating it.
This commit is contained in:
interp
parent
e43b8bb2fc
commit
f972598f59
|
|
@ -275,12 +275,6 @@
|
|||
(export with-lock*
|
||||
(with-lock :syntax)))
|
||||
|
||||
;; With the help of TYPED-OPTIONALS you can define a function
|
||||
;; like (make-submit-button [string] args)
|
||||
(define-interface typed-optionals-interface
|
||||
(export typed-optionals
|
||||
(optionals :syntax)))
|
||||
|
||||
;; Input-fields as Scheme-Objects
|
||||
(define-interface surflets/input-field-value-interface
|
||||
(export input-field?
|
||||
|
|
@ -550,17 +544,6 @@
|
|||
define-record-types)
|
||||
(files surflet-response))
|
||||
|
||||
|
||||
;; With the help of TYPED-OPTIONALS you can define a function
|
||||
;; like (make-submit-button [string] args)
|
||||
(define-structure typed-optionals typed-optionals-interface
|
||||
(open scheme
|
||||
receiving ;receive
|
||||
srfi-23 ;error
|
||||
surflets/utilities ;rev-append
|
||||
(subset srfi-1 (make-list)))
|
||||
(files typed-optionals))
|
||||
|
||||
;; Extensions to Olegs SSAX library
|
||||
(define-structure surflets/sxml surflets/sxml-interface
|
||||
(open scheme-with-scsh ;string-ports
|
||||
|
|
@ -590,8 +573,7 @@
|
|||
;; avoid name collision for member
|
||||
(modify srfi-1 (rename (member member/srfi-1)))
|
||||
define-record-types
|
||||
(subset let-opt (:optional))
|
||||
(subset typed-optionals (optionals))
|
||||
let-opt
|
||||
surflets/my-input-fields
|
||||
surflets/utilities ;generate-unique-number
|
||||
surflets/sxml
|
||||
|
|
@ -606,7 +588,6 @@
|
|||
(subset surflets/my-input-fields
|
||||
(*input-field-trigger* input-field-html-tree))
|
||||
surflets/sxml
|
||||
typed-optionals
|
||||
(subset sxml-tree-trans (pre-post-order)))
|
||||
(files surflet-sxml))
|
||||
|
||||
|
|
|
|||
|
|
@ -21,9 +21,9 @@
|
|||
(define (simple-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?))
|
||||
(let-optionals maybe-further-attributes
|
||||
((default "" default-pred)
|
||||
(attributes '() sxml-attribute?))
|
||||
(make-input-field name type
|
||||
transformer
|
||||
(make-field-attributes
|
||||
|
|
@ -101,25 +101,23 @@
|
|||
;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;;; Textarea input field
|
||||
(define (make-textarea . maybe-further-attributes)
|
||||
(let ((name (generate-input-field-name "textarea")))
|
||||
(optionals maybe-further-attributes
|
||||
((default-text simple-default?)
|
||||
(rows number?)
|
||||
(cols number?)
|
||||
(readonly symbol?)
|
||||
(attributes sxml-attribute?))
|
||||
(let ((extra-attributes
|
||||
(list `(cols ,(or cols 20))
|
||||
`(rows ,(or rows 5))
|
||||
(and (eq? readonly 'readonly)
|
||||
'(readonly)))))
|
||||
(let-optionals maybe-further-attributes
|
||||
((default-text "" simple-default?)
|
||||
(rows 5 number?)
|
||||
(cols 20 number?)
|
||||
(readonly #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(let ((name (generate-input-field-name "textarea"))
|
||||
(all-attributes `((cols ,cols)
|
||||
(rows ,rows)
|
||||
,@(if readonly '(readonly) '())
|
||||
,@(sxml-attribute-attributes attributes))))
|
||||
(make-input-field
|
||||
name "textarea"
|
||||
identity
|
||||
(make-field-attributes
|
||||
(and default-text)
|
||||
(cons extra-attributes (sxml-attribute-attributes attributes)))
|
||||
make-textarea-html-tree)))))
|
||||
(make-field-attributes (and default-text)
|
||||
all-attributes)
|
||||
make-textarea-html-tree))))
|
||||
|
||||
(define (make-textarea-html-tree textarea)
|
||||
(let ((attributes (input-field-attributes textarea)))
|
||||
|
|
@ -166,16 +164,16 @@
|
|||
|
||||
;; Constructor for valued select input-field option.
|
||||
(define (make-annotated-select-option tag value . maybe-attributes)
|
||||
(optionals maybe-attributes
|
||||
((selected? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(let-optionals maybe-attributes
|
||||
((selected? #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(make-select-option tag value selected? attributes)))
|
||||
|
||||
;; Constructor for a simple select input-field option (not annotated).
|
||||
(define (make-simple-select-option tag . maybe-attributes)
|
||||
(optionals maybe-attributes
|
||||
((selected? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(let-optionals maybe-attributes
|
||||
((selected? #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(make-select-option tag tag selected? attributes)))
|
||||
|
||||
(define-record-discloser :select-option
|
||||
|
|
@ -267,9 +265,9 @@
|
|||
|
||||
(define (really-make-select select-options maybe-further-attributes)
|
||||
(let ((real-select-options (tolerate-old-select-options select-options)))
|
||||
(optionals maybe-further-attributes
|
||||
((multiple? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(let-optionals maybe-further-attributes
|
||||
((multiple? #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(let ((name (generate-input-field-name "select")))
|
||||
(if multiple?
|
||||
(make-multiple-select name select-options attributes)
|
||||
|
|
@ -282,8 +280,8 @@
|
|||
select-multiple-transformer
|
||||
(make-field-attributes
|
||||
select-options
|
||||
(list '(multiple)
|
||||
(sxml-attribute-attributes attributes)))
|
||||
`((multiple)
|
||||
,@(sxml-attribute-attributes attributes)))
|
||||
make-select-html-tree))
|
||||
|
||||
;; internal
|
||||
|
|
@ -333,15 +331,15 @@
|
|||
(define (make-radio-group)
|
||||
(let ((name (generate-input-field-name "radio")))
|
||||
(lambda (value-string . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((checked? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(let-optionals maybe-further-attributes
|
||||
((checked? #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(make-input-field name "radio"
|
||||
identity
|
||||
(make-field-attributes
|
||||
(if checked? '(checked) #f)
|
||||
(list `(value ,value-string)
|
||||
(sxml-attribute-attributes attributes)))
|
||||
(and checked? '(checked))
|
||||
`((value ,value-string)
|
||||
,@(sxml-attribute-attributes attributes)))
|
||||
radio-html-tree-maker)))))
|
||||
|
||||
(define (make-annotated-radio-group)
|
||||
|
|
@ -349,22 +347,22 @@
|
|||
(value-table (make-integer-table))
|
||||
(transformer (make-radio-transformer value-table)))
|
||||
(lambda (value . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((checked? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(let-optionals maybe-further-attributes
|
||||
((checked? #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(let ((number (generate-unique-number)))
|
||||
(table-set! value-table number value)
|
||||
(make-input-field name "radio"
|
||||
transformer
|
||||
(make-field-attributes
|
||||
(if checked? '(checked) #f)
|
||||
(list`(value ,(number->string number))
|
||||
(sxml-attribute-attributes attributes)))
|
||||
(and checked? '(checked))
|
||||
`((value ,(number->string number))
|
||||
,@(sxml-attribute-attributes attributes)))
|
||||
radio-html-tree-maker))))))
|
||||
|
||||
(define (make-radios values . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((attributes sxml-attribute?))
|
||||
(let-optionals maybe-further-attributes
|
||||
((attributes '() sxml-attribute?))
|
||||
(let ((radio-gen (make-annotated-radio-group)))
|
||||
(map (lambda (value)
|
||||
(if attributes
|
||||
|
|
@ -416,13 +414,13 @@
|
|||
|
||||
(define (really-make-checkbox value transformer attributes)
|
||||
(let ((name (generate-input-field-name "checkbox")))
|
||||
(optionals attributes
|
||||
((checked? boolean?)
|
||||
(attributes sxml-attribute?))
|
||||
(let-optionals attributes
|
||||
((checked? #f boolean?)
|
||||
(attributes '() sxml-attribute?))
|
||||
(make-input-field name "checkbox"
|
||||
transformer
|
||||
(make-field-attributes
|
||||
(if checked? '(checked) #f)
|
||||
(and checked? '(checked))
|
||||
(sxml-attribute-attributes attributes))
|
||||
checkbox-html-tree-maker))))
|
||||
|
||||
|
|
@ -464,22 +462,22 @@
|
|||
,(field-attributes-others attributes)))))
|
||||
|
||||
(define (make-submit-button . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((button-caption string?)
|
||||
(attributes sxml-attribute?))
|
||||
(let-optionals maybe-further-attributes
|
||||
((button-caption #f 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?))
|
||||
(let-optionals maybe-further-attributes
|
||||
((button-caption #f 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?))
|
||||
(let-optionals maybe-further-attributes
|
||||
((attributes '() sxml-attribute?))
|
||||
(make-button "image" (generate-input-field-name "imgbtn")
|
||||
#f `(@ (src ,image-source)
|
||||
,@(sxml-attribute-attributes attributes)))))
|
||||
|
|
@ -488,8 +486,8 @@
|
|||
;; send their simple name, but the coordinates where the user clicked
|
||||
;; into. Thanks to Eric Knauel for reporting this bug.
|
||||
(define (make-image-button image-source . maybe-further-attributes)
|
||||
(optionals maybe-further-attributes
|
||||
((attributes sxml-attribute?))
|
||||
(let-optionals maybe-further-attributes
|
||||
((attributes '() sxml-attribute?))
|
||||
(make-multi-input-field (generate-input-field-name "imgbtn")
|
||||
"image"
|
||||
image-button-transformer
|
||||
|
|
@ -518,5 +516,4 @@
|
|||
(cdr pair)))
|
||||
(else #f))))
|
||||
|
||||
|
||||
;;EOF
|
||||
|
|
@ -36,7 +36,7 @@
|
|||
*preorder*
|
||||
. ,(lambda (trigger k-url . args)
|
||||
(receive (parameters elems)
|
||||
(typed-optionals (list symbol? sxml-attribute?) args)
|
||||
(optionals-first (list symbol? sxml-attribute?) args)
|
||||
(make-surflet-form k-url ; k-url
|
||||
(car parameters) ; POST, GET or #f=GET
|
||||
(cadr parameters); attributes
|
||||
|
|
@ -75,3 +75,41 @@
|
|||
(define (surflet-sxml->low-level-sxml sxml-tree)
|
||||
(pre-post-order sxml-tree surflet-sxml-rules))
|
||||
|
||||
|
||||
|
||||
;;; Helping funtion for surflet-sxml-rule
|
||||
|
||||
;; PRED-LIST contains list of predicates that recognizes optional
|
||||
;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter
|
||||
;; list as got by procedure call. TYPED-OPTIONALS returns two values:
|
||||
;; a list of the same length as PRED-LIST and a list containing the
|
||||
;; left arguments that did not fit the predicates.
|
||||
;;
|
||||
;; With the help of OPTIONALS-FIRST you can define a function
|
||||
;; like `make-submit-button [string] [further-attributes]' this way:
|
||||
;; (define (make-submit-button . args)
|
||||
;; (receive (params rest-args)
|
||||
;; (prefix-optionals (list string? xml-attribute?) args)
|
||||
;; (if (pair? rest-args)
|
||||
;; (error "too many arguments to make-submit-button))
|
||||
;; (let ((value (first params))
|
||||
;; (attributes (second params)))
|
||||
;; ...))))
|
||||
;;
|
||||
(define (optionals-first pred-list args)
|
||||
(let loop ((results '())
|
||||
(pred-list pred-list)
|
||||
(args args))
|
||||
(cond
|
||||
((null? pred-list)
|
||||
(values (reverse results) args))
|
||||
((null? args)
|
||||
(values (rev-append results (make-list (length pred-list) #f)) '()))
|
||||
(((car pred-list) (car args))
|
||||
(loop (cons (car args) results)
|
||||
(cdr pred-list)
|
||||
(cdr args)))
|
||||
(else
|
||||
(loop (cons #f results)
|
||||
(cdr pred-list)
|
||||
args)))))
|
||||
|
|
|
|||
|
|
@ -1,41 +0,0 @@
|
|||
;; PRED-LIST contains list of predicates that recognizes optional
|
||||
;; leading parameters. FURTHER-ATTRIBUTES is the optional parameter
|
||||
;; list as got by procedure call. TYPED-OPTIONALS returns two values:
|
||||
;; a list of the same length as PRED-LIST and a list containing the
|
||||
;; left arguments that did not fit the predicates.
|
||||
;;
|
||||
;; With the help of TYPED-OPTIONALS you can define a function
|
||||
;; like `make-submit-button [string] [further-attributes]' this way:
|
||||
;; (define (make-submit-button . args)
|
||||
;; (receive (params rest-args)
|
||||
;; (prefix-optionals (list string? xml-attribute?) args)
|
||||
;; (if (pair? rest-args)
|
||||
;; (error "too many arguments to make-submit-button))
|
||||
;; (let ((value (first params))
|
||||
;; (attributes (second params)))
|
||||
;; ...))))
|
||||
;;
|
||||
(define (typed-optionals pred-list args)
|
||||
(let loop ((results '())
|
||||
(pred-list pred-list)
|
||||
(args args))
|
||||
(cond
|
||||
((null? pred-list)
|
||||
(values (reverse results) args))
|
||||
((null? args)
|
||||
(values (rev-append results (make-list (length pred-list) #f)) '()))
|
||||
(((car pred-list) (car args))
|
||||
(loop (cons (car args) results)
|
||||
(cdr pred-list)
|
||||
(cdr args)))
|
||||
(else
|
||||
(loop (cons #f results)
|
||||
(cdr pred-list)
|
||||
args)))))
|
||||
|
||||
(define-syntax optionals
|
||||
(syntax-rules ()
|
||||
((optionals args ((name pred) ...) body)
|
||||
(receive (params must-be-empty)
|
||||
(typed-optionals (list pred ...) args)
|
||||
(apply (lambda (name ...) body) params)))))
|
||||
|
|
@ -29,7 +29,7 @@
|
|||
(let* ((checkboxes (map make-annotated-checkbox
|
||||
table-elements))
|
||||
(select (make-annotated-select
|
||||
actions '(@ (size 1))))
|
||||
actions #f '(@ (size 1))))
|
||||
(req
|
||||
(send-html/suspend
|
||||
(lambda (new-url)
|
||||
|
|
|
|||
Loading…
Reference in New Issue