sunet/scheme/httpd/surflets/surflet-sxml.scm

(define url-rule
  `(url *preorder*
	. ,(lambda (tag uri . maybe-text) 
	     (surflet-sxml->low-level-sxml
	      `(a (@ (href ,uri))
		  ,(if (null? maybe-text)
		       uri
		       maybe-text))))))

(define plain-html-rule
  `(plain-html
    *preorder*
    . ,(lambda (tag . text) text)))

(define nbsp-rule
  `(nbsp . ,(lambda (_) " ")))

(define comment-rule
  `(*COMMENT* *preorder* 
              . ,(lambda (tag . elems)
                   `("<!-- "
                     ,@elems
                     "-->"))))

(define default-rules
 `(,attribute-rule
   ,default-rule
   ,text-rule
   ,comment-rule
   ,url-rule
   ,plain-html-rule
   ,nbsp-rule))

(define surflet-form-rule
  `(surflet-form 
    ;; Must do something to prevent the k-url string to be HTML
    ;; escaped.
    *preorder*
    . ,(lambda (trigger k-url . args)
	 (receive (parameters elems)
	     (typed-optionals (list symbol? sxml-attribute?) args)
	   (make-surflet-form k-url ; k-url
			      (car parameters) ; POST, GET or #f=GET
			      (cadr parameters); attributes
			      elems)))))

(define (make-surflet-form k-url method attributes elems)
  (let ((real-method (case method
		       ((get GET) "GET")
		       ((post POST) "POST")
		       ((#f) "GET")
		       (else
			(error "invalid method type" method)))))
    (surflet-sxml->low-level-sxml 
     `(form (@ ((method ,real-method)
		(action ,k-url)
		,@(if attributes (cdr attributes) '())))
	    ,@elems))))

(define input-field-rule
  `(,*input-field-trigger*
    *preorder*
    . ,(lambda (trigger input-field)
	 (surflet-sxml->low-level-sxml
	  ;; We need a real input-field for input-field-html-tree.
	  (input-field-html-tree (list trigger input-field))))))

(define surflet-sxml-rules
  `(,@default-rules
     ;; form contents:
     ,input-field-rule
     ,surflet-form-rule))

;; Low-Level-SXML is a list that can be understood by
;; display-low-level-sxml. In contains only characters, strings, and
;; thunks.
(define (surflet-sxml->low-level-sxml sxml-tree)
  (pre-post-order sxml-tree surflet-sxml-rules))