#|-------------------- 0.2 |# "./autoform.meta" 371
;;; autoform.meta -*- scheme -*-

((egg "autoform.egg")
 (synopsis "Generates HTML forms out of database structures")
 (author "<a href=\"http://chicken.wiki.br/users/mario-domenech-goulart\">Mario Domenech Goulart</a>")
 (license "BSD")
 (category web)
 (needs sql-null html-tags html-utils spiffy-request-vars)
 (files "autoform.setup" "autoform.meta" "autoform.scm"))

#|-------------------- 0.2 |# "./autoform.scm" 10328
(module autoform
  (make-db-field
   autoform
   date-fields-format
   mandatory-fields
   db-field-mandatory?
   db-field-type
   date-type?
   form-id
   get-database-structure
   javascript-validation:int-only-message
   javascript-validation:float-only-message
   javascript-validation:date-format-message
   javascript-validation:common
   javascript-validation:int
   javascript-validation:float
   javascript-validation:date
   javascript-validation:observer
   javascript-validators
   javascript-validation:form-submit
   javascript-validation:missing-message
   javascript-validation:highlight-missing
   autoform-db-connection?
   autoform-db-connect
   autoform-db-disconnect)

(import chicken scheme data-structures ports files)
(use (srfi 1 13))
(use spiffy-request-vars sql-null html-tags html-utils)

(define date-fields-format (make-parameter "dd/mm/yyyy"))

(define (date-type? type)
  (or (string-prefix? "timestamp" type)
      (string-prefix? "date" type)))

;;; Javascript validation

(define javascript-validation:int-only-message
  (make-parameter ""))

(define javascript-validation:float-only-message
  (make-parameter ""))

(define javascript-validation:date-format-message
  (make-parameter ""))

(define javascript-validation:common
  (make-parameter ""))

(define javascript-validation:int
  (make-parameter ""))

(define javascript-validation:float
  (make-parameter ""))

(define javascript-validation:date
  (make-parameter ""))

(define javascript-validation:observer
  (make-parameter
   (lambda (elt-id event action)
     "")))

(define (mandatory-fields fields)
  (filter-map (lambda (field)
                (let ((var (car field))
                      (field-obj (cdr field)))
                  (and (db-field-mandatory? field-obj)
                       var)))
              fields))

(define javascript-validation:highlight-missing
  (make-parameter ""))

(define javascript-validation:missing-message
  (make-parameter ""))

(define javascript-validation:form-submit
  (make-parameter
   (lambda (table fields)
     "")))

(define javascript-validators
  (make-parameter
   (lambda (form-obj events/actions)
     "")))

;;; DB structure
(define autoform-db-connection?
  (make-parameter
   (lambda (conn)
     (error "Select a valid autoform database support module."))))

(define autoform-db-connect
  (make-parameter
   (lambda (credentials)
     (error "Select a valid autoform database support module."))))

(define autoform-db-disconnect
  (make-parameter
   (lambda (conn)
     (error "Select a valid autoform database support module."))))

(define get-database-structure
  (make-parameter
   (lambda (conn table)
     (error "Select a valid autoform database support module."))))

;;; Form generation

(define-record db-field type maxlen mandatory?)

(define (form-id table)
  (string-append table "_form"))

(define (make-form-object db-table conn extra-fields close-connection)

  (define (fill-db-field db-item)
    (let ((type (cdr db-item))
          (maxlen (let ((maxlen (cadr db-item)))
                    (if (or (sql-null? maxlen) (eq? maxlen #f))
                        #f
                        maxlen)))
          (mandatory? (let ((mandatory (caddr db-item)))
                        (if (string? mandatory)
                            (equal? mandatory "NO")
                            mandatory))))
      (make-db-field type maxlen mandatory?)))

  (let* ((conn (and conn (if ((autoform-db-connection?) conn)
                             conn
                             ((autoform-db-connect) conn))))
         (db-data (if conn ((get-database-structure) conn db-table) '()))
         (form-obj
          (append
           (cons db-table
                 (append
                  (map (lambda (db-item)
                         (cons (string->symbol (car db-item)) ;; column_name
                               (apply make-db-field (cdr db-item)))) ;; db-field object
                       db-data)
                  extra-fields)))))
    (when close-connection ((autoform-db-disconnect) conn))
    form-obj))

(define (autoform db-table conn #!key (extra-fields '())
                                      close-connection
                                      (labels '())
                                      (widgets '())
                                      (default-values '())
                                      (force-mandatory '())
                                      (disabled-fields '())
                                      (read-only-fields '())
                                      (password-fields '())
                                      (form-method 'post)
                                      form-action
                                      submit-label
                                      layout
                                      list-layout
                                      tabular-layout
                                      (events/actions '())
                                      (mandatory-indicator (lambda (_) (string-append _ " (*)"))))

  ;; Return the HTML widget for the given `field-obj'
  (define (field-widget var field-obj #!optional value)
    (or (and-let* ((widget (alist-ref var widgets)))
          (widget var))
        (let* ((type (db-field-type field-obj))
               (maxlen (db-field-maxlen field-obj))
               (type-is-date (date-type? type))
               (date-fields-length (string-length (date-fields-format))))
          (cond
           ;; textareas
           ((equal? type "text")
                 (<textarea> id: var
                             name: var
                             value: value
                             disabled: (alist-ref var disabled-fields)
                             readonly: (alist-ref var read-only-fields)))

           ;; hidden
           ((equal? type "hidden")
            (hidden-input var (or value (alist-ref var labels))))

           (else
            (<input> type: (cond ((or (equal? type "password")
                                      (alist-ref var password-fields))
                                  "password")
                                 ((equal? type "boolean")
                                  "checkbox")
                                 (else "text"))
                     id: var
                     name: var
                     value: value
                     maxlength: (if type-is-date
                                    date-fields-length
                                    maxlen)
                     size: (and type-is-date date-fields-length)
                     ))))))

  ;; Return a <span> containing the label and the widget for the given
  ;; `form-obj'
  (define (format-field var field-obj)
    (let ((mandatory-indicator (if (db-field-mandatory? field-obj)
                                   mandatory-indicator
                                   identity)))
      (<span> id: (conc var "_container")
              (mandatory-indicator
               (<label> id: (conc var "_label")
                        (or (alist-ref var labels) var)))
              (field-widget var field-obj (alist-ref var default-values)))))

  (define (invalid-field-message var)
    (conc 'render-form-object ": '" var "' is not a valid field."))

  (define (format-list-layout table items)
    (itemize
     (map (lambda (item)
            (format-field (car item) (cdr item)))
          items)
     list-id: table))

  (define (format-tabular-layout table items layout)
    (<table> id: (string-append table "_table")
             (string-intersperse
              (map (lambda (row)
                     (<tr> (string-intersperse
                            (map (lambda (cell)
                                   (<td> (if cell
                                             (let ((field (alist-ref cell items)))
                                               (if field
                                                   (format-field cell field)
                                                   (error (invalid-field-message cell))))
                                             "")))
                                 row))))
                   layout))))

  (define (format-no-layout table items)
    (<div> id: table
           (string-intersperse
            (map (lambda (item)
                   (format-field (car item) (cdr item)))
                 items))))

  (define (html-form table fields sorted-fields)
    (<form> id: (string-append table "_form")
            action: form-action
            method: form-method
            (cond (list-layout (format-list-layout table sorted-fields))
                  (tabular-layout (format-tabular-layout table fields tabular-layout))
                  (else (format-no-layout table sorted-fields)))
            (submit-input id: (string-append table "_submit") value: submit-label)))

  (let* ((form-obj (make-form-object db-table conn extra-fields close-connection))
         (table (car form-obj))
         (fields (cdr form-obj))
         (sorted-fields
          (if (or layout list-layout)
              (map (lambda (var)
                     (let ((item (alist-ref var fields)))
                       (if item
                           (cons var item)
                           (error (invalid-field-message var)))))
                   (or layout list-layout))
              fields)))

    ;; Set mandatory fields according to `force-mandatory'
    (for-each (lambda (field)
                (when (memq (car field) force-mandatory)
                  (db-field-mandatory?-set! (cdr field) #t)))
              fields)

    ;; autoform method dispatcher
    (lambda (method)
      (case method
        ((html)       (html-form table fields sorted-fields))
        ((javascript) ((javascript-validators)
                       (cons table
                             (filter (lambda (field)
                                       (memq (car field) (or layout
                                                             list-layout
                                                             (flatten tabular-layout))))
                                     fields))
                       events/actions))
        (else (error  (conc "autoform: invalid method: '" method "'."))))))

  ) ; end render-table-object

) ; end module

#|-------------------- 0.2 |# "./autoform.setup" 246
;;; autoform.setup -*- scheme -*-

(compile -s -O2 -d1 -j autoform autoform.scm)
(compile -s -O2 -d1 autoform.import.scm)

(install-extension 'autoform
                   '("autoform.so" "autoform.import.so")
                   '((version 0.2)))