From f972598f593ec1f6eb259f7381a205c50f784ddb Mon Sep 17 00:00:00 2001 From: interp Date: Wed, 9 Jul 2003 17:18:57 +0000 Subject: [PATCH] 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. --- scheme/httpd/surflets/packages.scm | 21 +-- .../httpd/surflets/surflet-input-fields.scm | 121 +++++++++--------- scheme/httpd/surflets/surflet-sxml.scm | 40 +++++- scheme/httpd/surflets/typed-optionals.scm | 41 ------ .../root/surflets/admin-surflets.scm | 2 +- 5 files changed, 100 insertions(+), 125 deletions(-) delete mode 100644 scheme/httpd/surflets/typed-optionals.scm diff --git a/scheme/httpd/surflets/packages.scm b/scheme/httpd/surflets/packages.scm index c98dd0d..3713988 100644 --- a/scheme/httpd/surflets/packages.scm +++ b/scheme/httpd/surflets/packages.scm @@ -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)) diff --git a/scheme/httpd/surflets/surflet-input-fields.scm b/scheme/httpd/surflets/surflet-input-fields.scm index 4793984..5ddf64b 100644 --- a/scheme/httpd/surflets/surflet-input-fields.scm +++ b/scheme/httpd/surflets/surflet-input-fields.scm @@ -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))))) - (make-input-field - name "textarea" - identity - (make-field-attributes - (and default-text) - (cons extra-attributes (sxml-attribute-attributes attributes))) - make-textarea-html-tree))))) + (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) + 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 \ No newline at end of file diff --git a/scheme/httpd/surflets/surflet-sxml.scm b/scheme/httpd/surflets/surflet-sxml.scm index b69ab8d..ca6ab97 100644 --- a/scheme/httpd/surflets/surflet-sxml.scm +++ b/scheme/httpd/surflets/surflet-sxml.scm @@ -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))))) diff --git a/scheme/httpd/surflets/typed-optionals.scm b/scheme/httpd/surflets/typed-optionals.scm deleted file mode 100644 index 690826b..0000000 --- a/scheme/httpd/surflets/typed-optionals.scm +++ /dev/null @@ -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))))) diff --git a/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm b/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm index 3808c81..7028065 100644 --- a/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm +++ b/scheme/httpd/surflets/web-server/root/surflets/admin-surflets.scm @@ -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)