;;
;; 
;; HTML form constructor.
;;
;; Copyright 2007-2013 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 form-xsd)
		   
 (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 default rest)
  (or (and (pair? rest)
	   (filter-map
	    (lambda (prop)

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




(define (checkbox name label rel value . rest)
  `((br) (input (@ (type checkbox) (name ,name) (value ,(string-append value ";"))
	      ,(if rel `(rel ,rel) `()))) ,value))

(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) `())
	      ,(if (assoc 'multiple rest) `(multiple "yes") `()))
	   ,(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) `()))))




(define (widget-xsd name label rel default rest)
  (or (and (pair? rest)
	   (filter-map
	    (lambda (prop)
	      (case (car prop)
		((textarea)   `((xs:annotation 
                                 (xs:documentation 
                                  (@ (source "ospi.label")
                                     (xml:lang "en"))
                                  ,label))
                                (xs:simpleType
                                 (xs:restriction
                                  (@ (base "xs:string"))
                                  (xs:maxLength (@ (value "5000")))
                                  ))))

		((checkbox)   `((xs:annotation 
                                 (xs:documentation 
                                  (@ (source "ospi.label")
                                     (xml:lang "en"))
                                  ,label))
                                (xs:simpleType
                                 (xs:restriction
                                  (@ (base "xs:boolean"))
                                  (xs:enumeration (@ (value "true")))
                                  ))))

		((radio)   (let ((vals (map ->string (cadr prop))))

                             `((xs:annotation 
                                (xs:documentation 
                                 (@ (source "ospi.label")
                                    (xml:lang "en"))
                                 ,label))
                               (xs:simpleType
                                (xs:restriction
                                 (@ (base "xs:integer"))
                                 . ,(map (lambda (x) `(xs:enumeration (@ (value ,x))))
                                         (list-tabulate (length vals) (lambda (i) i)))
                                 ))
                               )))
                 
                 ((select)     (let ((vals (map ->string (cadr prop))))
                                `((xs:annotation 
                                   (xs:documentation 
                                    (@ (source "ospi.label")
                                       (xml:lang "en"))
                                    ,label))
                                  (xs:simpleType
                                  (xs:restriction
                                   (@ (base "xs:string"))
                                   . ,(map (lambda (x) `(xs:enumeration (@ (value ,x)))) vals)
                                  )))
                                ))
                 

		(else         #f)))
	    rest))
      `(xs:simpleType
        (xs:restriction
         (@ (base "xs:string"))
         (xs:maxLength (@ (value "100")))
         ))
      ))


(define (field-xsd 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))
	(multiple    (lookup-field 'multiple 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)))
    `(xs:element 
      (@ (name ,name)
         ,(if optional '(minOccurs "0") (if multiple '(minOccurs "1") '(minOccurs "unbounded"))))
      ,@(widget-xsd name label rel default rest))
    ))


(define (form-element-xsd x)
  (case (car x)
    ((form-group)  (group-xsd (cadr x) (cddr x)))
    (else          (apply field-xsd x))
    ))


(define (group-xsd group-name rest)
  (let ((children   (lookup-field 'children rest))
	(label      (lookup-field 'label rest)))
    `(xs:element 
      (@ (name ,group-name))
      (xs:complexType 
       (xs:sequence . ,(map form-element-xsd children))
      ))
    ))



(define (form-xsd title xs)
  (let recur ((xs xs) (ax '()))
    (if (null? xs)
        `(xs:schema
          (@ (xmlns:xs "http://www.w3.org/2001/XMLSchema")
             (elementFormDefault "qualified"))
          (xs:element (@ (name ,title))
                      (xs:complexType 
                       (xs:sequence . ,(reverse ax)))
                      )
          )
        (let* ((x   (car xs))
               (ax1 (cons (form-element-xsd x) ax)))
          (recur (cdr xs) ax1)
          ))
    ))
    



)