;;
;; 
;; Directed graph in adjacency list format.
;; Based on code from MLRISC
;;
;; Copyright 2007-2009 Ivan Raikov and the Okinawa Institute of Science and Technology.
;;
;;
;; This program is free software: you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation, either version 3 of the
;; License, or (at your option) any later version.
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.
;;
;; A full copy of the GPL license can be found at
;; <http://www.gnu.org/licenses/>.

(module html-form

 (html-form)
		   
 (import scheme chicken data-structures )

 (require-extension srfi-1 srfi-13 matchable data-structures )

(define nl (list->string (list #\newline)))

(define lookup-field 
  (lambda (k lst . rest)
    (let-optionals rest ((default #f))
      (let loop ((lst lst))
	(if (null? lst) default
	    (let ((elm (car lst)))
	      (match elm
		     ((s . _)  (if (eq? s k) (cdr elm)  (loop (cdr lst))))
		     (else  (loop (cdr lst))))))))))

(define (single x) (and x (or (and (list? x) (car x)) x)))

(define (s+ . rest) 
  (apply string-append (map ->string rest)))

(define special-attrs 
  `(label rel optional hint label-class hint-class field-class))

(define (special-attr? x) (member x special-attrs))

(define (pid parent id)
  (if parent (s+ parent "_" id) (->string id)))

(define (html-form x)
  (and (list? x)
       (case (car x)
	 ((form-group)  (group (cadr x) (cddr x)))
	 (else          (apply field x)))))

(define (group group-name rest)
  (let ((children   (lookup-field 'children rest))
	(label      (lookup-field 'label rest)))
    `(div (@ (id ,group-name))
	  (fieldset (@ (class repeat) )
		    (legend ,(or label group-name))
		    ,(map (lambda (x) (list (html-form x) nl)) (or children (list)))))))

(define (field name default . rest)
  (let ((hint        (lookup-field 'hint rest))
	(label       (or (lookup-field 'label rest) name))
	(rel         (lookup-field 'rel rest))
	(optional    (lookup-field 'optional rest))
	(field-class (or (lookup-field 'field-class rest) 'oneField))
	(label-class (or (lookup-field 'label-class rest) 'preField))
	(hint-class  (or (lookup-field 'hint-class rest) 'inlineLabel)))
  `(div (@ ,(if optional  `(rel ,optional)  `()))
	(span (@ (class ,field-class))
	      (label (@ (for ,name) (class ,label-class)) ,label)
	      ,(if hint `(p (@ (class ,hint-class)) ,hint)  `())
	      ,(widget name label rel default (filter (lambda (x) (not (special-attr? (car x)))) rest))))))

(define (widget name label rel value rest)
  (or (and (pair? rest)
	   (let ((prop (car rest)))
	     (case (car prop)
	       ((checkbox)   (checkbox name label rel value))
	       ((textarea)   (apply textarea (cons* name label rel value (cdr prop))))
	       ((select)     (apply selection (cons* name label rel (cdr prop))))
	       ((button)     (apply button (cons* name label rel value (cdr prop))))
	       ((radio)      (apply radio (cons* name label rel value (cdr prop))))
	       (else         #f))))
      (text name label rel value)))

(define (checkbox name label rel value . rest)
  `(input (@ (type checkbox) (name ,name) (id ,name) (title ,label) (value ,value)
	     ,(if rel `(rel ,rel) `()))))

(define (textarea name label rel value . rest)
  (let ((rows (single (lookup-field 'rows rest)))
	(cols (single (lookup-field 'cols rest)))
	(value (if (list? value) value (list value))))
    (if (not (and rows cols)) (error 'textarea "missing rows and cols attributes"))
    `((textarea (@ (name ,name) (id ,name) (rows ,rows) (cols ,cols) (title ,label)
	,(if rel `(rel ,rel) `())) ,nl
	,(let ((irows (if (string? rows) (string->number rows) rows))
	       (icols (if (string? cols) (string->number cols) cols)))
	   (let rloop ((i irows) (lst value) (ax (list)))
	     (let cloop ((j icols) (lst lst) (ax ax))
	       (if (null? lst) (reverse ax)
		   (if (> j 0) (cloop (- j 1) (cdr lst) (cons " " (cons (car lst) ax)))
		       (if (> i 1) (rloop (- i 1) lst (cons nl ax))  
			   (reverse (cons nl ax)))))))))
      (p))))


(define (selection name label rel value . rest)
  `(select (@ (name ,name) (id ,name) (title ,label) ,(if rel `(rel ,rel) `()))
	   ,(map (lambda (x) `((option (@ (value ,x) (label ,x)) ,x) ,nl)) value)))

(define (button name label rel value . rest)
  (let ((onclick  (lookup-field 'onclick rest)))
    `(input (@ (type button) (name ,name) (id ,name) (value ,value) (title ,label) 
	       ,(if rel `(rel ,rel) `()) 
	       ,(if onclick `(script (onclick  ,onclick)) `())))))

(define (radio name label rel value . rest)
  (map (lambda (x)  
	 (let-values (((rname ropts)  
		       (match x ((name . opts)  (values (->string name) opts))
			      (else  (values (->string x) (list))))))
		     (let ((rel (lookup-field 'rel ropts)))
		       `( ,rname ": "
				 (input (@ (type radio) (name ,name) (id ,(pid name rname))
					   (value ,rname) (title ,rname) 
					   ,(if rel `(rel ,rel) `())))))))
       rest))

(define (text name label rel value . rest)
  `(input (@ (name ,name) (id ,name) (title ,label) (value ,value)
	     ,(if (string? value) `(type "text") `())
	     ,(if rel `(rel ,rel) `()))))

)