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

	 (prefix (make-parameter ""))

	 (prefix-name (lambda (name) (string-append (prefix) name)))

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

	 (input (lambda (type #!optional extend)
		  (lambda (name . args) 
		    (let* ((name (prefix-name name))
			   (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)
				    (let ((name (prefix-name name)))
				      `(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* . ,(let ((attrs? (compose (cut eq? '@ <>) car)))
			     (lambda (tag attrs . body)
			       (parameterize ((prefix (last (or (and (not (attrs? attrs)) 
								     (find (compose (cut eq? 'prefix <>) car) attrs)) '("")))))

				 (let ((body (pre-post-order body informal-rules)))
				   (cons 'form (if (attrs? attrs) (cons attrs (list body))
						   (let ((attrs (find attrs? attrs)))
						     (if attrs (cons attrs body) body)))))))))

      ,@alist-conv-rules)))

)