scsh-conservatory
/
sunet
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
scheme/httpd/surflets/packages.scm
View File

@ -275,12 +275,6 @@
(export with-lock* (export with-lock*
(with-lock :syntax))) (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 ;; Input-fields as Scheme-Objects
(define-interface surflets/input-field-value-interface (define-interface surflets/input-field-value-interface
(export input-field? (export input-field?
@ -550,17 +544,6 @@
define-record-types) define-record-types)
(files surflet-response)) (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 ;; Extensions to Olegs SSAX library
(define-structure surflets/sxml surflets/sxml-interface (define-structure surflets/sxml surflets/sxml-interface
(open scheme-with-scsh ;string-ports (open scheme-with-scsh ;string-ports
@ -590,8 +573,7 @@
;; avoid name collision for member ;; avoid name collision for member
(modify srfi-1 (rename (member member/srfi-1))) (modify srfi-1 (rename (member member/srfi-1)))
define-record-types define-record-types
(subset let-opt (:optional)) let-opt
(subset typed-optionals (optionals))
surflets/my-input-fields surflets/my-input-fields
surflets/utilities ;generate-unique-number surflets/utilities ;generate-unique-number
surflets/sxml surflets/sxml
@ -606,7 +588,6 @@
(subset surflets/my-input-fields (subset surflets/my-input-fields
(*input-field-trigger* input-field-html-tree)) (*input-field-trigger* input-field-html-tree))
surflets/sxml surflets/sxml
typed-optionals
(subset sxml-tree-trans (pre-post-order))) (subset sxml-tree-trans (pre-post-order)))
(files surflet-sxml)) (files surflet-sxml))

121
scheme/httpd/surflets/surflet-input-fields.scm
View File

@ -21,9 +21,9 @@
(define (simple-field-maker reported-type type default-pred transformer) (define (simple-field-maker reported-type type default-pred transformer)
(lambda maybe-further-attributes (lambda maybe-further-attributes
(let ((name (generate-input-field-name type))) (let ((name (generate-input-field-name type)))
(optionals maybe-further-attributes (let-optionals maybe-further-attributes
((default default-pred) ((default "" default-pred)
(attributes sxml-attribute?)) (attributes '() sxml-attribute?))
(make-input-field name type (make-input-field name type
transformer transformer
(make-field-attributes (make-field-attributes
@ -101,25 +101,23 @@
;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;
;;; Textarea input field ;;; Textarea input field
(define (make-textarea . maybe-further-attributes) (define (make-textarea . maybe-further-attributes)
(let ((name (generate-input-field-name "textarea"))) (let-optionals maybe-further-attributes
(optionals maybe-further-attributes ((default-text "" simple-default?)
((default-text simple-default?) (rows 5 number?)
(rows number?) (cols 20 number?)
(cols number?) (readonly #f boolean?)
(readonly symbol?) (attributes '() sxml-attribute?))
(attributes sxml-attribute?)) (let ((name (generate-input-field-name "textarea"))
(let ((extra-attributes (all-attributes `((cols ,cols)
(list `(cols ,(or cols 20)) (rows ,rows)
`(rows ,(or rows 5)) ,@(if readonly '(readonly) '())
(and (eq? readonly 'readonly) ,@(sxml-attribute-attributes attributes))))
'(readonly))))) (make-input-field
(make-input-field name "textarea"
name "textarea" identity
identity (make-field-attributes (and default-text)
(make-field-attributes all-attributes)
(and default-text) make-textarea-html-tree))))
(cons extra-attributes (sxml-attribute-attributes attributes)))
make-textarea-html-tree)))))
(define (make-textarea-html-tree textarea) (define (make-textarea-html-tree textarea)
(let ((attributes (input-field-attributes textarea))) (let ((attributes (input-field-attributes textarea)))
@ -166,16 +164,16 @@
;; Constructor for valued select input-field option. ;; Constructor for valued select input-field option.
(define (make-annotated-select-option tag value . maybe-attributes) (define (make-annotated-select-option tag value . maybe-attributes)
(optionals maybe-attributes (let-optionals maybe-attributes
((selected? boolean?) ((selected? #f boolean?)
(attributes sxml-attribute?)) (attributes '() sxml-attribute?))
(make-select-option tag value selected? attributes))) (make-select-option tag value selected? attributes)))
;; Constructor for a simple select input-field option (not annotated). ;; Constructor for a simple select input-field option (not annotated).
(define (make-simple-select-option tag . maybe-attributes) (define (make-simple-select-option tag . maybe-attributes)
(optionals maybe-attributes (let-optionals maybe-attributes
((selected? boolean?) ((selected? #f boolean?)
(attributes sxml-attribute?)) (attributes '() sxml-attribute?))
(make-select-option tag tag selected? attributes))) (make-select-option tag tag selected? attributes)))
(define-record-discloser :select-option (define-record-discloser :select-option
@ -267,9 +265,9 @@
(define (really-make-select select-options maybe-further-attributes) (define (really-make-select select-options maybe-further-attributes)
(let ((real-select-options (tolerate-old-select-options select-options))) (let ((real-select-options (tolerate-old-select-options select-options)))
(optionals maybe-further-attributes (let-optionals maybe-further-attributes
((multiple? boolean?) ((multiple? #f boolean?)
(attributes sxml-attribute?)) (attributes '() sxml-attribute?))
(let ((name (generate-input-field-name "select"))) (let ((name (generate-input-field-name "select")))
(if multiple? (if multiple?
(make-multiple-select name select-options attributes) (make-multiple-select name select-options attributes)
@ -282,8 +280,8 @@
select-multiple-transformer select-multiple-transformer
(make-field-attributes (make-field-attributes
select-options select-options
(list '(multiple) `((multiple)
(sxml-attribute-attributes attributes))) ,@(sxml-attribute-attributes attributes)))
make-select-html-tree)) make-select-html-tree))
;; internal ;; internal
@ -333,15 +331,15 @@
(define (make-radio-group) (define (make-radio-group)
(let ((name (generate-input-field-name "radio"))) (let ((name (generate-input-field-name "radio")))
(lambda (value-string . maybe-further-attributes) (lambda (value-string . maybe-further-attributes)
(optionals maybe-further-attributes (let-optionals maybe-further-attributes
((checked? boolean?) ((checked? #f boolean?)
(attributes sxml-attribute?)) (attributes '() sxml-attribute?))
(make-input-field name "radio" (make-input-field name "radio"
identity identity
(make-field-attributes (make-field-attributes
(if checked? '(checked) #f) (and checked? '(checked))
(list `(value ,value-string) `((value ,value-string)
(sxml-attribute-attributes attributes))) ,@(sxml-attribute-attributes attributes)))
radio-html-tree-maker))))) radio-html-tree-maker)))))
(define (make-annotated-radio-group) (define (make-annotated-radio-group)
@ -349,22 +347,22 @@
(value-table (make-integer-table)) (value-table (make-integer-table))
(transformer (make-radio-transformer value-table))) (transformer (make-radio-transformer value-table)))
(lambda (value . maybe-further-attributes) (lambda (value . maybe-further-attributes)
(optionals maybe-further-attributes (let-optionals maybe-further-attributes
((checked? boolean?) ((checked? #f boolean?)
(attributes sxml-attribute?)) (attributes '() sxml-attribute?))
(let ((number (generate-unique-number))) (let ((number (generate-unique-number)))
(table-set! value-table number value) (table-set! value-table number value)
(make-input-field name "radio" (make-input-field name "radio"
transformer transformer
(make-field-attributes (make-field-attributes
(if checked? '(checked) #f) (and checked? '(checked))
(list`(value ,(number->string number)) `((value ,(number->string number))
(sxml-attribute-attributes attributes))) ,@(sxml-attribute-attributes attributes)))
radio-html-tree-maker)))))) radio-html-tree-maker))))))
(define (make-radios values . maybe-further-attributes) (define (make-radios values . maybe-further-attributes)
(optionals maybe-further-attributes (let-optionals maybe-further-attributes
((attributes sxml-attribute?)) ((attributes '() sxml-attribute?))
(let ((radio-gen (make-annotated-radio-group))) (let ((radio-gen (make-annotated-radio-group)))
(map (lambda (value) (map (lambda (value)
(if attributes (if attributes
@ -416,13 +414,13 @@
(define (really-make-checkbox value transformer attributes) (define (really-make-checkbox value transformer attributes)
(let ((name (generate-input-field-name "checkbox"))) (let ((name (generate-input-field-name "checkbox")))
(optionals attributes (let-optionals attributes
((checked? boolean?) ((checked? #f boolean?)
(attributes sxml-attribute?)) (attributes '() sxml-attribute?))
(make-input-field name "checkbox" (make-input-field name "checkbox"
transformer transformer
(make-field-attributes (make-field-attributes
(if checked? '(checked) #f) (and checked? '(checked))
(sxml-attribute-attributes attributes)) (sxml-attribute-attributes attributes))
checkbox-html-tree-maker)))) checkbox-html-tree-maker))))
@ -464,22 +462,22 @@
,(field-attributes-others attributes))))) ,(field-attributes-others attributes)))))
(define (make-submit-button . maybe-further-attributes) (define (make-submit-button . maybe-further-attributes)
(optionals maybe-further-attributes (let-optionals maybe-further-attributes
((button-caption string?) ((button-caption #f string?)
(attributes sxml-attribute?)) (attributes '() sxml-attribute?))
(make-button "submit" (generate-input-field-name "submit") (make-button "submit" (generate-input-field-name "submit")
button-caption attributes))) button-caption attributes)))
(define (make-reset-button . maybe-further-attributes) (define (make-reset-button . maybe-further-attributes)
(optionals maybe-further-attributes (let-optionals maybe-further-attributes
((button-caption string?) ((button-caption #f string?)
(attributes sxml-attribute?)) (attributes '() sxml-attribute?))
(make-button "reset" (generate-input-field-name "reset") (make-button "reset" (generate-input-field-name "reset")
button-caption attributes))) button-caption attributes)))
(define (make-image-button image-source . maybe-further-attributes) (define (make-image-button image-source . maybe-further-attributes)
(optionals maybe-further-attributes (let-optionals maybe-further-attributes
((attributes sxml-attribute?)) ((attributes '() sxml-attribute?))
(make-button "image" (generate-input-field-name "imgbtn") (make-button "image" (generate-input-field-name "imgbtn")
#f `(@ (src ,image-source) #f `(@ (src ,image-source)
,@(sxml-attribute-attributes attributes))))) ,@(sxml-attribute-attributes attributes)))))
@ -488,8 +486,8 @@
;; send their simple name, but the coordinates where the user clicked ;; send their simple name, but the coordinates where the user clicked
;; into. Thanks to Eric Knauel for reporting this bug. ;; into. Thanks to Eric Knauel for reporting this bug.
(define (make-image-button image-source . maybe-further-attributes) (define (make-image-button image-source . maybe-further-attributes)
(optionals maybe-further-attributes (let-optionals maybe-further-attributes
((attributes sxml-attribute?)) ((attributes '() sxml-attribute?))
(make-multi-input-field (generate-input-field-name "imgbtn") (make-multi-input-field (generate-input-field-name "imgbtn")
"image" "image"
image-button-transformer image-button-transformer
@ -518,5 +516,4 @@
(cdr pair))) (cdr pair)))
(else #f)))) (else #f))))
;;EOF ;;EOF

40
scheme/httpd/surflets/surflet-sxml.scm
View File

@ -36,7 +36,7 @@
*preorder* *preorder*
. ,(lambda (trigger k-url . args) . ,(lambda (trigger k-url . args)
(receive (parameters elems) (receive (parameters elems)
(typed-optionals (list symbol? sxml-attribute?) args) (optionals-first (list symbol? sxml-attribute?) args)
(make-surflet-form k-url ; k-url (make-surflet-form k-url ; k-url
(car parameters) ; POST, GET or #f=GET (car parameters) ; POST, GET or #f=GET
(cadr parameters); attributes (cadr parameters); attributes
@ -75,3 +75,41 @@
(define (surflet-sxml->low-level-sxml sxml-tree) (define (surflet-sxml->low-level-sxml sxml-tree)
(pre-post-order sxml-tree surflet-sxml-rules)) (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)))))

41
scheme/httpd/surflets/typed-optionals.scm
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)))))

2
scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm
View File

@ -29,7 +29,7 @@
(let* ((checkboxes (map make-annotated-checkbox (let* ((checkboxes (map make-annotated-checkbox
table-elements)) table-elements))
(select (make-annotated-select (select (make-annotated-select
actions '(@ (size 1)))) actions #f '(@ (size 1))))
(req (req
(send-html/suspend (send-html/suspend
(lambda (new-url) (lambda (new-url)