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 2003-07-09 17:18:57 +00:00
parent e43b8bb2fc
commit f972598f59
5 changed files with 100 additions and 125 deletions

View File

@ -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))

View File

@ -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

View File

@ -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)))))

View File

@ -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)))))

View File

@ -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)