(module sxml-informal (informal-rules)

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

(define informal-rules 
  (let* ((prefix (make-parameter ""))
	 
	 (element (lambda parts
		    (lambda (tag args)
		      (let* ((name (car args))
                             (args (cdr args))
                             (id (get-keyword id: args))
                             (prefixed-name (conc (prefix) name))
			     (id (if id (conc (prefix) id) prefixed-name))
			     (args (cons* prefixed-name id: id args))
			     (element (fold (lambda (part element)
					      (receive (expanded-element . classes)
						(apply part (cons (car element) args))
						(cons (or expanded-element (car element))
						      (append (cdr element) classes))))
					    '(())
					    parts))
			     (class (cons* (->string tag) name (cdr element)))
			     (class (if (string=? name id)
					class
					(cons id class))))
			`(li (@ (class ,(string-intersperse class))) ,@(car element))))))


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

	 (error (lambda (el name #!key error)
		  (and error
		       (let ((error (if (and (list? error) (= 1 (length error)))
					(car error)
					error)))
			 
			 (values (cond ((string? error) 
					(append el `((span (@ (class "error")) ,error))))
				       ((pair? error)
					(if (symbol? (car error)) 
					    error
					    (append el `((ul (@ (class "errors"))
							     ,@(map (cut list 'li <>) error))))))
				       (else #f))
				 "invalid")))))

	 (input (lambda (type #!optional extend)
		  (lambda (el name #!rest args #!key value (id name))
		    (let* ((input `(input (@ (type ,type) (id ,id) (name ,name)
					     ,@(if value `((value ,value)) '())))))
		      (append el (list (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") error))
      (password . ,(element label (input "password") error))
      (checkbox . ,(element (input "checkbox" checkable) label error))
      (radio    . ,(let ((input (element (input "radio" checkable) label error)))
		     (lambda (tag args)
                       (let* ((name (car args))
                              (args (cdr args))
                              (value (get-keyword value: args))
                              (suffix (or (get-keyword suffix: args) (and value (conc "-" value)))))
                         (input tag (cons* name id: (if suffix (conc name suffix) name) args))))))

      (hidden   . ,(let ((input (input "hidden")))
		     (lambda (tag args)
                       (let* ((name (car args))
                              (value (cadr args)))
                         (car (input '() name value: value))))))

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

      (select   . ,(element label 
		     (lambda (el name #!key options value)
		       (append el `((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)))))
		     error))

      (submit   . ,(let ((element (element (input "submit"))))
		     (lambda (tag args)
                       (let* ((label (car args))
                              (name (or (get-keyword name: (cdr args)) "commit")))
                         (element tag `(,name value: ,label))))))

      (fields *macro* . ,(lambda (tag elements)
			   (receive (options elements)
			     (cond ((string? (car elements))
				    (values `((legend . ,(car elements))) (cdr elements)))
				   ((and (pair? (car elements)) (pair? (caar elements)))
				    (values (map (cut apply cons <>) (car elements))
					    (cdr elements)))
				   (else (values '() elements)))

			     (parameterize ((prefix (if (assq 'prefix options)
							(conc (prefix) (alist-ref 'prefix options))
							(prefix))))

			       `(fieldset ,@(if (assq 'legend options) 
						`((legend ,(alist-ref 'legend options)))
						'())
					  (ol ,@(pre-post-order* elements informal-rules)))))))

      (informal *macro* . ,(let ((attrs? (compose (cut eq? '@ <>) car)))
			     (lambda (tag els)
                               (let ((attrs (car els))
                                     (body (cdr els)))
                                 (parameterize ((prefix (car (or (and (not (attrs? attrs)) 
                                                                      (alist-ref 'prefix attrs)) '("")))))
                                   (let ((body (pre-post-order* body informal-rules)))
                                     `(form ,(if (attrs? attrs) attrs (assq '@ attrs)) ,@body)))))))

      ,@alist-conv-rules*)))

)