(module sxml-informal (informal-rules)

(import chicken scheme)
(use sxml-transforms data-structures srfi-1 sxpath-lolevel)

(define informal-rules 
  (let ((element (lambda parts
		   (lambda (tag name . args)
		     (let ((args (cons (->string name) args)))
		       (cons 'li (fold-right (lambda (part el)
					       (let ((part (apply part args)))
						 (if part (cons part el) el))) '() parts))))))

	(label (lambda (name #!key label) 
		 (and label `(label (@ (for ,name)) ,label))))

	(input (lambda (type #!optional extend)
		 (lambda (name . args) 

		   (let ((input `(input (@ (type ,type) (id ,name) (name ,name) (value ,(get-keyword value: args))))))
		     (if extend (apply extend (cons input args)) input)))))

	(checkable (lambda (box #!key checked)
		     (if checked
			 (sxml:add-attr box `(checked "checked")) box))))

    `((string   . ,(element label (input "text")))
      (password . ,(element label (input "password")))
      (checkbox . ,(element (input "checkbox" checkable) label))
      (radio    . ,(element (input "radio" checkable) label))
      (hidden   . ,(let ((input (input "hidden")))
		     (lambda (tag name value)
		       (input name value: value))))

      (text     . ,(element label (lambda (name #!key value)
				    `(textarea (@ (id ,name) (name ,name) ) ,value))))

      (select   . ,(element label (lambda (name #!key options value)
				    `(select (@ (id ,name) (name ,name))
					     ,@(map (lambda (o) 
						      (let ((option `(option (@ (value ,(car o))) ,(cadr o))))
							(if (eq? value (car o))
							    (sxml:add-attr option '(selected "selected"))
							    option))) options)))))

      (submit   . ,(let ((element (element (input "submit"))))
		     (lambda (tag label #!key (name "commit"))
		       (element tag name value: label))))

      (fields *macro* . ,(lambda (tag #!optional legend . elements) 
			   `(fieldset ,@(if legend `((legend ,legend)) '()) (ol ,@elements))))

      (informal *macro* . ,(lambda (tag attrs . body)
			     `(form ,attrs ,body)))

      ,@alist-conv-rules)))

)