;;;; -*- lisp -*-
;; Copyright (c) 2003-2005 Edward Marco Baringer
;; All rights reserved. 
;; 
;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions are
;; met:
;; 
;;  - Redistributions of source code must retain the above copyright
;;    notice, this list of conditions and the following disclaimer.
;; 
;;  - Redistributions in binary form must reproduce the above copyright
;;    notice, this list of conditions and the following disclaimer in the
;;    documentation and/or other materials provided with the distribution.
;; 
;;  - Neither the name of Edward Marco Baringer, nor BESE, nor the names
;;    of its contributors may be used to endorse or promote products
;;    derived from this software without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT
;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :org.unknownlamer.ucw-im)

;; we need this pair to delay execution of functions which contain yacml macros
;; before the right place

(defun force (value)
  "Pseudo lazy-evaluation FORCE. Complementary to DELAY."
  (if (consp value)
      (case (car value)
        (:%delayed% (let ((vs (multiple-value-list (funcall (cdr value)))))
                      (setf (car value) :%force-done%
                            (cdr value) vs)
                      (apply #'values vs)))
        (:%force-done% (values-list (cdr value)))
        (otherwise value))
      value))

(defmacro delay (&rest forms)
  "Pseudo lazy-evaluation DELAY. Complementary to FORCE."
  `(cons :%delayed% #'(lambda () (progn ,@forms))))

(defmacro with-simple-restore (places &body forms)
  "Preserve values of setfable PLACES before execution of the FORMS
and restore them after. Returns the result of the FORMS."
  (let ((keepers (mapcar #'(lambda (p) (declare (ignore p)) (gensym))
                         places)))
    `(let ,keepers
       (setf (values ,@keepers) (values ,@places))
       (prog1
           (progn ,@forms)
         (setf (values ,@places) (values ,@keepers))))))

;; (eval-when (:compile-toplevel :load-toplevel :execute)
;;    (defclass interface-element-class (standard-component-class
;;                                       indirect-value-mixin-class)
;;      ()
;;      (:documentation "Metaclass for interface elements.")))

(define-ie-type (t t-element) (widget-component standard-component)
  ((view :accessor view
         :initarg :view
         :initform (make-instance 'ieview)
         :documentation "Element presentation control.")
   (label :accessor label 
          :initarg :label 
          :initform nil)
   (label-plural :accessor label-plural 
                 :initarg :label-plural 
                 :initform nil)
   (editablep :accessor editablep
              :initarg :editablep
              :initform t
              :documentation
              "T - render element with ACCEPT method
NIL - render element with PRESENT method")
   (enabledp :accessor enabledp
             :initarg :enabledp
             :initform t
             :documentation
             "Has element be shown to a client.
T - present element,
NIL - don't present element."))
  (:metaclass standard-component-class)
  (:documentation "Just a basic interface element"))

(defmethod present :around ((element t-element) (view ieview))
  (render-box element view
	      (delay (render-value-box element view
				       (delay (call-next-method))))))

(defmethod accept :around ((element t-element) (view ieview))
  (render-box element view
	      (delay (render-value-box element view
				       (delay (call-next-method))))))

(defmethod render ((e t-element))
  (when (enabledp e)
    (render-element (view e) e)))

(defmethod render-box ((e t-element) (view ieview) value)
  (declare (ignore view e))
  (force value))

(defmethod render-value-box ((e t-element) (view ieview) value)
  (declare (ignore view e))
  (force value))

(defgeneric render-element (view element)
  (:method-combination wrapping-standard))

(defmethod render-element ((view ieview) (e t-element))
  (when (labelp view)
    (render-label view e))
  (funcall (if (editablep e) #'accept #'present)
	   e
	   view))

(defmethod render-label ((view ieview) (e t-element))
  (awhen (ecase (labelp view)
           (:plural (or (label-plural e) ""))
           ((:singular t) (or (label e) ""))
           ((nil) nil))
    (<:as-html (if (functionp it) (funcall it e) it))))

(defgeneric slot-elements (element &key ie-type test)
  (:documentation "Returns all the slots names of ELEMENT
which are interface elements  and optionally satisfied the TEST.
TEST -- function of one argument (slot value).")
  (:method-combination nconc))

(defmethod slot-elements nconc ((e t-element) &key (ie-type 't) (test (constantly t)))
  (iterate
    (with interface-element-class = (ie-type-class ie-type))
    (for slot in (mopp:class-slots (class-of e)))
    (for slot-name = (mopp:slot-definition-name slot))
    (for element = (and (slot-boundp e slot-name)
                        (slot-value e slot-name)))
    (when (and element
               (not (eq element (parent e)))
               (not (and (slot-boundp e 'it.bese.ucw::calling-component)
                         (eq element (slot-value e 'it.bese.ucw::calling-component))))
               (subtypep (class-of element) interface-element-class)
               (funcall test element))
      (collect slot-name))))

(defgeneric clone-element (obj &rest initargs)
  (:documentation "Clone interface element."))

(defmethod clone-element ((obj t-element) &rest initargs)
  (let ((class (class-of obj))
        copy-initargs)
    (setf copy-initargs
          (iterate
            (with ses = (slot-elements obj))
            (for slot in (mopp:class-slots class))
            (for slot-name = (mopp:slot-definition-name slot))
            (for slot-initarg = (car (mopp:slot-definition-initargs slot)))

            (when (and slot-initarg     ; skip slots without initarg
                       (slot-indirect-boundp obj slot-name))
              (let ((sv (slot-indirect-value obj slot-name)))
                (appending
                 (list slot-initarg
                       (cond ((member slot-name ses) (clone-element sv))
                             ((indirect-value-p sv) (copy-indirect-value sv))
                             (t sv)     ; haven't other ideas
                             )))))))
    (apply #'make-instance class (append initargs copy-initargs))))

(define-ie-type (interface-element interface-element) ((ie-type t))
  ((client-value :accessor client-value :initform ""
		 :initarg :client-value
                 :documentation "Whetever the client's browse sent for this interface element."
                 :backtrack t)
   (direct-value :accessor direct-value :initform nil
                 :initarg :direct-value
                 :documentation "The current lisp object in this interface element."
                 :backtrack t)
   (default-value :accessor default-value
     :initarg :default-value
     :initform nil
     :documentation
     "Default LISP-VALUE.
If it is a function it is called with ELEMENT as argument.")
   (input-filter :accessor input-filter
                 :initarg :input-filter
                 :initform (lambda (value &optional element)
                             (declare (ignore element))
                             value)
                 :documentation
                 "Function/symbol of two arguments.
 (input-filter client-value interface-element) => LISP-VALUE.

Function can signal an uninterrupted error with
SIGNAL-IE-BAD-INPUT CLIENT-VALUE REQUIRED-TYPE &optional CONDITION-TYPE
CONDITION-TYPE -- :format | :type | nil.")
   (output-format :accessor output-format
                  :initarg :output-format
                  :initform #'(lambda (v &optional e) (declare (ignore e)) v)
                  :documentation
                  "Function/symbol of two arguments.
OUTPUT-FORMAT LISP-VALUE INTERFACE-ELEMENT => CLIENT-VALUE.")
   (constraints :accessor constraints
                :initarg :constraints
                :initform nil
                :documentation
                "List of constraints => CONSTRAINT*.
CONSTRAINT -- CONSTRAINT-FUNCTION | CONSTRAINT-KEYWORD.
CONSTRAINT-FUNCTION -- function LISP-VALUE INTERFACE-ELEMENT => T | NIL
CONSTRAINT-KEYWORD -- key for predefined constraint
CONSTRAINT-FUNCTION can signal an uninterrupted error with
SIGNAL-IE-CONSTRAINT-VIOLATION FORMAT-CONTROL &rest FORMAT-ARGS.")
   (initial-focus :accessor initial-focus
                  :initarg :initial-focus
                  :initform nil)
   (element-id :accessor element-id
               :initarg :element-id
               :initform (random-string 32)))
  (:metaclass interface-element-class)
  (:documentation "A single value in a form.

A interface-element is, simply put, a wrapper for a value in an html
form."))

(defgeneric coerce-client-value (element value)
  (:method ((e interface-element) (value string))
    (if (= (length value) 0)
        nil
        value))
  (:documentation "Coerce CLIENT-VALUE to LISP-VALUE type."))

(defgeneric validate-value (element value &key &allow-other-keys)
  (:method ((e interface-element) value &key &allow-other-keys)
    (every #'(lambda (c)
               (etypecase c
                 (function (funcall c value e))
                 (keyword  (funcall (ie-constraint c) value e))))
           (constraints e)))
  (:documentation "Validate value with ELEMENT constraints. 
VALIDATE-VALUE ELEMENT VALUE => VALID
VALID        -- boolean."))

(defmethod present ((e interface-element) (view ieview))
  "Render interface element fore viewing."
  (declare (ignore view))
  (when (lisp-value e)
    (<:as-html (format-lisp-value e (lisp-value e)))))

(defmethod accept ((e interface-element) (view ieview))
  "Render interface element fore editing."
  (declare (ignore view))
  (<ucw:input :type "text" :accessor (slot-value e 'client-value)))

(defmethod filter-client-value ((e interface-element) value)
  (when value
    (funcall (input-filter e) value e)))

(defmethod output-format ((e interface-element))
  (with-slots ((fmt-ctrl output-format))
      e
    (if (stringp fmt-ctrl)
        #'(lambda (v e)
            (declare (ignore e))
            (format nil fmt-ctrl v))
        fmt-ctrl)))

(defmethod format-lisp-value ((e interface-element) value)
  (when value
    (funcall (output-format e) value e)))

(defmethod default-value ((e interface-element))
  (with-slots (default-value)
      e
    (if (functionp default-value)
        (funcall default-value e)
        default-value)))

(defmethod read-client-value :around ((e interface-element))
  (if (editablep e)
      (call-next-method)
      (lisp-value e)))

(defmethod read-client-value ((e interface-element))
  (if (client-value e)
    (reduce #'(lambda (val fun) (funcall fun e val))
            (list #'filter-client-value #'coerce-client-value)
            :initial-value (client-value e))))

(defmethod (setf client-value) :around (new (e interface-element))
  (call-next-method (format-lisp-value e (or new (default-value e))) e))

(defmethod (setf lisp-value) (new (e interface-element))
  ;; force using indirect-value
  (setf (slot-value e 'direct-value) new))

(defmethod (setf lisp-value) :after (new (e interface-element))
  (declare (ignore new))
  (setf (client-value e) (lisp-value e)))

(defmethod lisp-value ((e interface-element))
  ;; force using indirect-value
  (slot-value e 'direct-value))

(defmethod shared-initialize :after ((e interface-element) slot-names
                                     &rest initargs)
  (declare (ignore slot-names initargs))
  (setf (client-value e) (default-value e)))

(defmethod render :after ((e interface-element))
  (when (initial-focus e)
    (<ucw:script
     `(.focus (document.get-element-by-id ,(element-id e))))))


(defclass composite-view (ieview)
  ((rownum :accessor rownum
           :initarg :rownum
           :initform 0
           :documentation
           "Counter of rendered composite rows."))
  (:documentation "Composite presentation."))

(define-ie-type (composite composite-element) ((ie-type t))
  ((slot-view :accessor slot-view
              :initarg :slot-view
              :initform (make-instance 'composite-view)
              :documentation
              "View for slots rendering.")
   (invalid-slots :accessor invalid-slots
                  :initarg :invalid-slots
                  :initform nil
                  :documentation
                  "List of invalid slots."))
  (:metaclass standard-component-class))

(defun symbol-to-label (symbol &optional pluralp)
  (let ((label (string-capitalize
                (substitute #\space #\-
                            (symbol-name symbol)))))
    (if pluralp
        (format nil "~a~p" label 2)
        label)))

(defmethod shared-initialize :after ((c composite-element) slot-names &key lisp-value &allow-other-keys)
  (declare (ignore slot-names))
  (iterate
    (for sn in (slot-elements c))
    (for se = (slot-value c sn))
    (unless (label se)
      (setf (label se) (symbol-to-label sn)))
    (unless (label-plural se)
      (setf (label-plural se) (symbol-to-label sn t)))
    (setf (view se) (slot-view c)))
  (when lisp-value (setf (lisp-value c) lisp-value)))

(flet ((composite-present-accept-before (c)
	 (dolist (sn (slot-elements c))
	   (setf (css-class (slot-value c sn))
		 (and (editablep c)
		      (when (member sn (invalid-slots c) :key #'car)
			"ucw-invalid-slot"))))))
  (defmethod present :before ((c composite-element) view)
    (composite-present-accept-before c))
  (defmethod accept :before ((c composite-element) view)
    (composite-present-accept-before c)))

(defmethod render-value-box ((c composite-element) (view ieview) value)
  (declare (ignore view c value))
  (<:div :class "ucw-composite"
     (<:table :cellspacing 0 :cellpadding 0 :width "100%"
              (call-next-method))))

(defmethod render-row ((view composite-view) (value t) &key row-class)
  (<:tr :class (or row-class
                   (if (= 0 (mod (rownum view) 2)) "even-row" "odd-row"))
        (force value)))

(defmethod render-slot-value-box ((view composite-view) (c composite-element)
				  slot presenter)
  (declare (ignore c))
  (<:td :class "ucw-composite-slot-value" (funcall presenter slot view)))

(defmethod render-slot ((view composite-view) (c composite-element)
			(slot-name symbol) presenter)
  (when slot-name
    (let ((slot (slot-value c slot-name)))
      (render-slot view c slot presenter))))

(defmethod render-slot ((view composite-view) (c composite-element)
			(slot t-element) presenter)
  (let ((slot-view (slot-view c)))
    (with-simple-restore ((editablep slot) (view slot) (labelp slot-view))
      (setf (view slot) slot-view)
      (when (labelp slot-view)
        (<:td :class "ucw-composite-slot-label"
              (render-label slot-view slot))
        (setf (labelp slot-view) nil))
      (render-slot-value-box view c slot presenter))))

(defmethod render-slot ((view composite-view)(c composite-element)
			(slot-list sequence) presenter)
  (<:td
   (<:table
    (mapc #'(lambda (x)
              (<:tr
               (render-slot view c x presenter)))
          slot-list))))

(defmethod render-slot ((view composite-view) (c composite-element)
			slot-name presenter)
  (let ((slot (slot-value c slot-name))
        (slot-view (slot-view c)))
    (with-simple-restore ((editablep slot) (view slot) (labelp slot-view))
      (setf (view slot) slot-view)
      (unless (editablep c)
        (setf (editablep slot) nil))
      (when (labelp slot-view)
        (<:td :class "ucw-composite-slot-label"
              (render-label slot-view slot))
        (setf (labelp slot-view) nil))
      (render-slot-value-box view c slot presenter))))

(defmethod render-slots ((view t) (c composite-element) slot-names presenter)
  (setf (rownum (slot-view c)) 0)
  (mapc #'(lambda (slot-name)
            (incf (rownum (slot-view c)))
            (render-row (slot-view c)
                        (delay (render-slot (slot-view c) c slot-name presenter))))
        slot-names))

(defmethod accept ((c composite-element) (view t))
  "Render interface element fore editing."
  (render-slots view c (slot-elements c :test #'enabledp) #'accept))

(defmethod present ((c composite-element) (view t))
  "Render interface element fore viewing."
  (render-slots view c (slot-elements c :test #'enabledp) #'present))

(defmethod validp ((c composite-element))
  (not (invalid-slots c)))

(defmethod report-error ((c composite-element) slot-name condition)
  (declare (ignore c))
  (it.bese.ucw::ucw.component.info "~a - ~a~%" slot-name condition))

(defmethod collect-error ((c composite-element) slot-name condition)
  (report-error c slot-name condition)
  (push (cons slot-name condition) (invalid-slots c)))

(defmacro with-collect-error ((composite) &body body)
  (with-unique-names (error-collector collect-error)
    `(labels ((,error-collector (slot-name condition)
                (funcall #'collect-error ,composite slot-name condition))
              (,collect-error (condition)
                (let ((restart (find-restart 'collect-error)))
                  (when restart (invoke-restart restart
                                                #',error-collector
                                                condition)))))
       (handler-bind ((ie-condition #',collect-error))
         ,@body))))

(defmethod client-value :before ((c composite-element))
  (setf (invalid-slots c) nil))

(defmethod client-value ((c composite-element))
  (prog1
      (with-collect-error (c)
        (mapcar
         #'(lambda (slot-name)
             (cons slot-name
                   (restart-case (read-client-value 
                                  (slot-value c slot-name))
                     (collect-error (handler condition)
                       (funcall handler slot-name condition)
                       nil))))
         (slot-elements c)))
    (unless (validp c)                  ; propogate error
      (signal-ie-bad-input (invalid-slots c) 'input))))

(defmethod lisp-value ((c composite-element))
  (mapcar #'(lambda (slot-name)
              (cons slot-name (lisp-value (slot-value c slot-name))))
          (slot-elements c)))

(defmethod (setf lisp-value) (slot-alist (c composite-element))
  (mapc #'(lambda (slot-acons)
            (setf (lisp-value (slot-value c (car slot-acons)))
                  (cdr slot-acons)))
        slot-alist))

(defmethod (setf lisp-value) :after (slot-alist (c composite-element))
  (declare (ignore slot-alist))
  (setf (invalid-slots c) nil))

(defmethod validate-value :before ((c composite-element) value &key (clearp t))
  (declare (ignore value))
  (when clearp
    (setf (invalid-slots c) nil)))

(defmethod validate-value ((c composite-element) slot-alist &key (clearp t))
  (prog1
      (with-collect-error (c)
        (notany
         #'null (mapcar
                 #'(lambda (slot-acons)
                     (destructuring-bind (slot-name . value)
                         slot-acons
                       (restart-case 
                           (validate-value (slot-value c slot-name)
                                           value
                                           :clearp clearp)
                         (collect-error (handler condition)
                           (funcall handler slot-name condition)
                           nil))))
                 slot-alist)))
    (unless (validp c)                  ; propogate error
      (signal-ie-bad-input (invalid-slots c) 'input))))

(defmethod read-client-value ((c composite-element))
  (client-value c))

(defclass auxslots-composite-mixin (aux-slots-mixin)
  ())

(defmethod slot-elements nconc ((c auxslots-composite-mixin) &key (ie-type 't) (test #'identity))
  (iterate
    (with composite-element-class = (ie-type-class ie-type))
    (for slot-name in (aux-slots c))
    (for element = (slot-value c slot-name))
    (when (and element
               (subtypep (class-of element) composite-element-class)
               (funcall test element))
      (collect slot-name))))

(define-ie-type (auxslots-composite auxslots-composite-element) (auxslots-composite-mixin (ie-type composite))
  ()
  (:metaclass standard-component-class))

;;; Form Element

(defclass form-view (composite-view)
  ()
  (:documentation "Form presentation."))

(define-ie-type (form form-element) ((ie-type composite))
  ()
  (:metaclass standard-component-class))

(defmethod render-box ((f form-element) (view ieview) value)
  (declare (ignore view f value))
  (<:div :class "ucw-form-box" (call-next-method)))

(defmethod render-value-box ((f form-element) (view ieview) value)
  (declare (ignore value))
  (<:div :class "ucw-form"
         (<ucw:form :action (submit f) :method "post" (call-next-method))))

(defmethod render-label ((view ieview) (f form-element))
  (declare (ignore view f))
  (<:div :class "ucw-form-label" (call-next-method)))

(defmethod read-client-value ((f form-element))
  (let ((value (client-value f)))
    (validate-value f
                    (remove-if #'(lambda (sn) (member sn (invalid-slots f) :key #'car))
                               value
                               :key #'car)
                    :clearp nil)
    value))

;; remember that actions are just methods
(defgeneric/cc submit (form))

(defaction submit :before ((f form-element))
  (let ((value (read-client-value f)))
    (when (validp f)
      (setf (lisp-value f) value))))

(defaction submit ((f form-element))
  t)

(define-ie-type (auxslots-form auxslots-form-element) ((ie-type form) auxslots-composite-mixin)
  ()
  (:metaclass standard-component-class))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Various standard form element types

;;;; Generic Text 

(define-ie-type (text text-element) ((ie-type interface-element))
  ((size :accessor size :initarg :size :initform 0)
   (minlength :accessor minlength :initarg :minlength :initform 0) 
   (maxlength :accessor maxlength :initarg :maxlength :initform 32))
  (:metaclass interface-element-class)
  (:default-initargs
    :input-filter #'(lambda (str e) (declare (ignore e)) (string-trim '(#\Space #\Tab) str))))

(define-ie-constraint-method :length-range ((value string) (e (ie-type text))
                                            &key (min (minlength e))
                                            (max (maxlength e)))
  (call-next-method value e :min min :max max))

(defmethod accept ((e text-element) (view ieview))
  (declare (ignore view))
  (<ucw:input :id (element-id e)
              :type "text" :class "ucw-text-element" :accessor (slot-value e 'client-value)
              :size (size e)
              :maxlength (maxlength e)))

(defvar *completing-text-element-prefix-counter* 0)

(define-ie-type (completing-text completing-text-element) ((ie-type text))
  ((completions :accessor completions :initarg :completions :initform nil)
   (prefix :accessor prefix :initarg :prefix :initform "completing-text-element")
   (completer.js-path :accessor completer.js-path
		      :initarg :completer.js-path
		      :initform "/ucw/js/UCWInputCompleter.js")
   (completer-class :accessor completer-class
		    :initarg :completer-class
		    :initform "UCWInputCompleter"))
  (:metaclass interface-element-class)
  (:documentation "A text input element with javascript based completion.

This component requires, over and above the component object
itself, the UCWInputCompleter.js java script file and a
stylesheet.

The stylesheet, though not not strictly required, is STONGLY
suggested. The following styles are used:

div#<PREFIX>-results - Used for the div which wraps all the
available completions.

div#<PREFIX>-results ul - Used for the UL which wraps the list of
completions.

div#<PREFIX>-results ul li - Every completions is placed in the body
of an LI tag, use this style to change the formatting of the
single completions.

li#<PREFIX>-highlight - Use this style to change the formatting
of a selected completions.

In the above css selectors <PREFIX> is the value of component's
prefix slot.

Customizing the UCWInputCompleter object (setting auto
completion, minimum number of chars, etc.) is, unfortunetly, done
by creating a new javascript class (in a new javascript file) and
using that instead of UCWInputCompleter.js. In the near future
this situation will improve."))

(defmethod accept ((e completing-text-element) (view ieview))
  (declare (ignore view))
  (<ucw:input :id (element-id e)
              :type "text" :accessor (slot-value e 'client-value)
	      :size (size e) :id (concatenate 'string (prefix e) "-input"))
  (<:div :id (concatenate 'string (prefix e) "-results"))
  (<:script :type "text/javascript" :src (completer.js-path e)
	    ;; for some weird reason firefox doesn't like empty script
	    ;; tags. this empty string is neccessary to force yaclml
	    ;; to produce a <script ..></script> as opposed to <script
	    ;; .../>
	    "")
  (<ucw:script
   `(let ((cloader
           (lambda ()
             (let ((completer (js:new (,(make-symbol (strcat ":" (completer-class e))) ,(prefix e)))))
               (setf completer.table (js:array ,@(completions e)))
               (completer.load)))))
      (cloader))))

;;;; text areas

(define-ie-type (text-area text-area-element) ((ie-type text))
  ((rows :accessor rows :initform nil :initarg :rows)
   (cols :accessor cols :initform nil :initarg :cols))
  (:metaclass interface-element-class))

(defmethod accept ((e text-area-element) (view ieview))
  (declare (ignore view))
  (<ucw:textarea :id (element-id e)
                 :accessor (slot-value e 'client-value) :rows (rows e) :cols (cols e)))

;;;; SELECT/OPTION

(define-ie-type (selector select-element) ((ie-type interface-element))
  ((options :accessor options :initform '() :initarg :options)
   (key :accessor key :initform #'identity :initarg :key)
   (test :accessor test :initform #'eql :initarg :test)
   (multiple :accessor multiple :initarg :multiple :initform nil))
  (:metaclass interface-element-class)
  (:default-initargs :output-format "~a"))

;;;; The lisp-value is a single value if multiple is nil otherwise a list.
;;;; the lisp-value is related to the options in that (for non-multiple)
;;;;   (funcall (test select-element) (funcall (key select-element) an-option) lisp-value) =>T
;;;; The client-value is always either an option or a list of options.

(defmethod coerce-client-value ((e select-element) value)
  ;;Apply the key to preserve the relationship between the lisp-value and the client-value
  (if (multiple e)
      (mapcar (key e) value)
      (funcall (key e) value)))

(defmethod format-lisp-value ((e select-element) value)
  ;;get the option or list of options that correspond to the selected value(s)
  (when value
    (flet ((find-v (v)
             (find v (options e) :key (key e) :test (test e))))
      (if (multiple e)
          (mapcar #'find-v value)
          (funcall #'find-v value)))))

(defmethod render-option ((e select-element) (object t))
  (<:as-html (funcall (output-format e) object e)))

(defmethod accept ((e select-element) (view ieview))
  (declare (ignore view))
  (<ucw:select :accessor (slot-value e 'client-value)
               :multiple (multiple e)
               :key #'identity ;we have already done the keying, so underneath just use ID
               :test (test e)
               ;;the <:ucw:option macro will take care of adding the selected property
               ;;properly based upon the value of the accessor above.
     (iterate
       (for o in (options e))
       (<ucw:option :value o
          (render-option e o)))))

(defmethod present ((e select-element) (view ieview))
  (declare (ignore view))
  (iterate
    (with os = (format-lisp-value e (lisp-value e)))
    (for o in (if (multiple e) os (when os (list os))))
    (render-option e o)))

;;;; Numbers from text inputs

(define-ie-type (number number-element) ((ie-type interface-element))
  ((min-value :accessor min-value :initform nil :initarg :min-value)
   (max-value :accessor max-value :initform nil :initarg :max-value)
   (size :accessor size :initform 20 :initarg :size))
  (:metaclass interface-element-class)
  (:default-initargs
    :input-filter #'(lambda (v e) (declare (ignore e)) (string-trim '(#\Space #\Tab) v))
    :output-format "~a"))

(define-ie-constraint-method :number-range (value (e number-element)
                                                  &key (min (min-value e))
                                                  (max (max-value e)))
  (call-next-method value e :min min :max max))

(defmethod coerce-client-value ((number number-element) value)
  (declare (ignore value))
  (let ((*read-eval* nil))
    (when-bind str (call-next-method)
      (multiple-value-bind (value value-end)
          (handler-case
              (read-from-string str)
            (end-of-file ()
              (signal-ie-bad-input str 'number :type)))
        (if (and (numberp value) (>= value-end (length str)))
            value
            (signal-ie-bad-input str 'number :type))))))

(defmethod accept ((n number-element) (view ieview))
  (declare (ignore view))
  (<ucw:input :id (element-id n)
              :type "text" :size (size n)
	      :accessor (slot-value n 'client-value)))

(define-ie-type (decimal decimal-element) ((ie-type number))
  ((precision :accessor precision :initarg :precision :initform nil
              :documentation "Number of significant digits."))
  (:metaclass interface-element-class))

(defmethod coerce-client-value ((decimal decimal-element) value)
  (declare (ignore value))
  (when-bind num (call-next-method)
    (if-bind prec (precision decimal)
      (let ((div (expt 10 (- prec))))
        (float (/ (rationalize (floor (+ (rationalize num) (/ div 2)) div))
                  (expt 10 prec))))
      (float num))))

(define-ie-type (integer integer-element) ((ie-type number))
  ()
  (:metaclass interface-element-class))

(defmethod coerce-client-value ((integer integer-element) value)
  (declare (ignore value))
  (when-bind num (call-next-method)
    (truncate num)))

(define-ie-type (integer-range integer-range-element) ((ie-type integer))
  ()
  (:metaclass interface-element-class)
  (:default-initargs :min-value 1 :max-value 5))

(defmethod shared-initialize :after ((e integer-range-element) slot-names
                                     &key &allow-other-keys)
  (declare (ignore slot-names))
  (with-slots (default-value) e
    (unless default-value
      (setf default-value (min-value e)))))

(defmethod accept ((range integer-range-element) (view ieview))
  (declare (ignore view))
  (<:select :name (make-new-callback (lambda (v) (setf (slot-value  range 'client-value) v)))
    (iterate
      (for value from (min-value range) to (max-value range))
      (<:option :value value
                :selected (eq value (read-client-value range))
                (<:as-html (format-lisp-value range value))))))

;;;; Password field

(define-ie-type (password password-element) ((ie-type interface-element))
  ((size :accessor size :initarg :size :initform 0)
   (minlength :accessor minlength :initarg :minlength :initform 0) 
   (maxlength :accessor maxlength :initarg :maxlength :initform 20))
  (:metaclass interface-element-class)
  (:default-initargs
    :input-filter #'(lambda (str e) (declare (ignore e)) (string-trim '(#\Space #\Tab) str))))

(defmethod accept ((e password-element) (view ieview))
  (declare (ignore view))
  (<ucw:input :id (element-id e)
              :type "password" :class "ucw-password-element" :accessor (slot-value e 'client-value)
              :size (size e)
              :maxlength (maxlength e)))

;;;; Boolean checkbox

(define-ie-type (checkbox checkbox-element) ((ie-type interface-element))
  ()
  (:metaclass interface-element-class)
  (:default-initargs
    :input-filter #'(lambda (str e) (declare (ignore e)) (if (stringp str)
                                                             (string-trim '(#\Space #\Tab) str)))))

(defmethod accept ((e checkbox-element) (view ieview))
  (<ucw:input :id (element-id e)
              :type "checkbox" :class "ucw-checkbox-element" :accessor (slot-value e 'client-value)))

(defmethod coerce-client-value ((checkbox checkbox-element) value)
  (if value
      t
      nil))

;;;; Sets
(defclass set-view (form-view)
  ()
  (:documentation "Sets presentation."))

(define-ie-type (set set-element) ((ie-type t))
  ((item-viewer :accessor item-viewer
                :initarg :item-viewer
                :initform nil
                :documentation
                "Interface element for viewing single item.")
   (current-item :accessor current-item
                 :initarg :current-item
                 :initform nil
                 :documentation
                 "Currently viewed item.")
   (items :accessor items
          :initarg :items
          :initform nil
          :documentation
          "List of items."))
  (:metaclass interface-element-class)
  (:default-initargs
    :view (make-instance 'set-view)
    :editablep nil))

(defmethod render-box ((set set-element) (view ieview) value)
  (render-box (item-viewer set) view value))

(defmethod render-value-box ((set set-element) (view ieview) value)
  (render-value-box (item-viewer set) view value))

(defmethod render-element ((view ieview) (set set-element))
  (with-slots (item-viewer editablep view)
      set
    (with-simple-restore ((editablep item-viewer) (view item-viewer))
      (setf (editablep item-viewer) editablep
            (view item-viewer) view)
      (call-next-method))))

(defmethod render-label ((view ieview) (set set-element))
  (render-label view (item-viewer set)))

(defmethod render-slot-labels ((view set-view) (set set-element) slots)
  (dolist (slot slots)
    (<:th (render-label view (slot-value (item-viewer set) slot)))))

(defmethod render-slot ((view set-view) (set set-element) slot-name presenter)
  (let ((slot (slot-value (item-viewer set) slot-name)))
    (with-simple-restore ((editablep slot))
      (setf (editablep slot) nil)
      (<:td :class "ucw-composite-slot-value"
            (funcall presenter slot view)))))


(defmethod render-item ((view set-view) (set set-element) item
			slot-names presenter)
  (setf (lisp-value (item-viewer set)) item)
  (iterate
    (for slot-name in slot-names)
    (render-slot view set slot-name presenter)))

(defmethod render-items ((view set-view) (set set-element) slot-names presenter)
  (with-slots ((iv item-viewer)) set
    (render-row view
                (delay (render-slot-labels view set slot-names))
                :row-class "label-row")
    (setf (rownum view) 0)
    (with-slots (slot-view) iv
      (with-simple-restore ((labelp slot-view))
        (setf (labelp slot-view) nil)
        (mapc #'(lambda (item)
                  (setf (lisp-value iv) item)
                  (incf (rownum view))
                  (render-row view
                              (delay (render-item view set item
						  slot-names presenter))))
              (items set))))))

(defmethod accept ((set set-element) (view t))
  (error "sorry, not yet implemented."))

(defmethod present ((set set-element) (view t))
  (render-items view set (slot-elements (item-viewer set) :test #'enabledp)
		#'present)

  ;; prevent last item from been damaged by backtracking
  ;; we only want to do this if the slot is using indirect-value
  (mapc #'(lambda (slot-name)
            (let ((slot (slot-value (item-viewer set) slot-name)))
              (when (slot-indirect-p slot 'direct-value)
                (slot-makunbound slot 'direct-value))))
        (slot-elements (item-viewer set) :ie-type 'interface-element :test #'enabledp)))