;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*-
;;; $Header: src/translators.lisp $

;;; Copyright (c) 2008, Andrea Chiumenti.  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.

;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; 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 AUTHOR 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 :claw-html)

(defgeneric translator-encode (translator wcomponent)
  (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string)."))

(defgeneric translator-type-to-string (translator wcomponent)
  (:documentation "Encodes the input component value, used when rendering the component (Encodes from type to string). It's a wrapper for translator-encode"))

(defgeneric translator-decode (translator wcomponent)
  (:documentation "Decodes the input component value after a form submit (Decodes from string to type)."))

(defgeneric translator-string-to-type (translator wcomponent)
  (:documentation "Decodes the input component value after a form submit (Decodes from string to type). It's a wrapper for translator-decode"))

(defgeneric translator-value-encode (translator value)
  (:documentation "Encodes the value, used when rendering the component (Encodes from type to string)."))

(defgeneric translator-value-type-to-string (translator value)
  (:documentation "Encodes the value, used when rendering the component (Encodes from type to string). It's a wrapper for translator-value-encode"))

(defgeneric translator-value-decode (translator value &optional client-id label)
  (:documentation "Decodes value after a form submit (Decodes from string to type)."))

(defgeneric translator-value-string-to-type (translator value &optional client-id label)
  (:documentation "Decodes value after a form submit (Decodes from string to type). It's a wrapper for translator-value-decode"))

(defgeneric validation-error-control-string (translator)
  (:documentation "Returns a control string that accepts a label attribute.
This control string is then used on translation exceptions.
"))

(defclass translator ()
  ((validation-error-control-string :initarg :validation-error-control-string
                                    :reader validation-error-control-string
                                    :documentation "Control string that accepts a label attribute"))
  (:documentation "A translator object encodes and decodes values passed to a html input component")
  (:default-initargs :validation-error-control-string nil))

(defmethod translator-value-encode ((translator translator) value)
  (if value
      (format nil "~a" value)
      ""))

(defmethod translator-value-type-to-string ((translator translator) value)
  (translator-value-encode translator value))

(defmethod translator-encode ((translator translator) (wcomponent base-cinput))
  (let* ((page (htcomponent-page wcomponent))
         (visit-object (cinput-visit-object wcomponent))
         (accessor (cinput-accessor wcomponent))
         (reader (cinput-reader wcomponent))
         (value (page-req-parameter page (name-attr wcomponent) nil)))
    (if (or (component-validation-errors wcomponent) (null visit-object))
        value
        (progn
          (setf value (cond
                        ((and (null reader) accessor) (funcall (fdefinition accessor) visit-object))
                        (reader (funcall (fdefinition reader) visit-object))))
          (if (listp value)
              (loop for item in value
                   collect (translator-value-encode translator item))
              (translator-value-encode translator value))))))

(defmethod translator-type-to-string ((translator translator) (wcomponent cinput))
  (translator-encode translator wcomponent))

(defmethod translator-value-decode ((translator translator) value &optional client-id label)
  (declare (ignore client-id label))
  value)

(defmethod translator-value-string-to-type ((translator translator) value &optional client-id label)
  (translator-value-decode translator value client-id label))

(defmethod translator-decode ((translator translator) (wcomponent wcomponent))
  (multiple-value-bind (client-id value)
      (component-id-and-value wcomponent)
    (if (listp value)
        (loop for item in value
                   collect (translator-value-decode translator item client-id (label wcomponent)))
        (translator-value-decode translator value client-id (label wcomponent)))))

(defmethod translator-string-to-type ((translator translator) (wcomponent wcomponent))
  (translator-decode translator wcomponent))

(setf *simple-translator* (make-instance 'translator))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;; Integer translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass translator-integer (translator)
  ((thousand-separator :initarg :thousand-separator
                       :reader translator-thousand-separator
                       :documentation "If specified (as character), it is the thousands separator. Despite of
its name, grouping is done following the TRANSLATOR-GROUPING-SIZE, so it's not a real 'tousands' separator")
   (always-show-signum :initarg :always-show-signum
                       :reader translator-always-show-signum
                       :documentation "When true the signum is used also for displaying positive numbers.")
   (grouping-size :initarg :grouping-size
                  :reader translator-grouping-size
                  :documentation "Used only if TRANSLATOR-THOUSAND-SEPARATOR is defined. Default to 3"))
  (:default-initargs :thousand-separator nil
    :grouping-size 3
    :always-show-signum nil)
  (:documentation "A translator object encodes and decodes integer values passed to a html input component"))

(defmethod translator-value-encode ((translator translator-integer) value)
  (let* ((grouping-size (translator-grouping-size translator))
         (thousand-separator (translator-thousand-separator translator))
         (signum-directive (if (translator-always-show-signum translator)
                               "@"
                               ""))
         (control-string (if thousand-separator
                             (format nil "~~~d,',v:~aD" grouping-size signum-directive)
                             (format nil "~~~ad"  signum-directive))))
    (if thousand-separator
        (string-trim " " (format nil control-string thousand-separator value))
        (format nil control-string value))))

(defmethod translator-value-decode ((translator translator-integer) value &optional client-id label)
  (let ((thousand-separator (translator-thousand-separator translator)))
    (handler-case
        (if thousand-separator
            (parse-integer (regex-replace-all (format nil "~a" thousand-separator) value ""))
            (parse-integer value))
      (error () (progn
                  (when label
                    (add-validation-error client-id (format nil (or (validation-error-control-string translator)
                                                                    "Field ~a is not a valid integer.") label)))
                  value)))))

(defvar *integer-translator*  
  (make-instance 'translator-integer)
  "Default instance for TRANSLATOR-INTEGER class")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;Folating point number translator ;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass translator-number (translator-integer)
  ((decimals-separator :initarg :decimals-separator
                       :reader translator-decimals-separator
                       :documentation "The decimal separator of the rendered number. Default to #\.")
   (decimal-digits :initarg :decimal-digits
                   :reader translator-decimal-digits
                   :documentation "force the rendering of the value to a fixed number of decimal digits")
   (coerce :initarg :coerce
           :accessor translator-coerce
           :documentation "Coerces the decoded input value to the given value type"))
  (:default-initargs :decimals-separator #\.
    :decimal-digits nil
    :coerce 'ratio)
  (:documentation "a translator object encodes and decodes integer values passed to a html input component"))


(defmethod translator-value-encode ((translator translator-number) value)
  (let* ((thousand-separator (translator-thousand-separator translator))
         (grouping-size (translator-grouping-size translator))
         (decimal-digits (translator-decimal-digits translator))
         (decimals-separator (translator-decimals-separator translator))
         (signum-directive (if (translator-always-show-signum translator) "@" ""))
         (integer-control-string (if thousand-separator
                                     (format nil "~~~d,',v:~aD"  grouping-size signum-directive)
                                     (format nil "~~~ad"  signum-directive))))
    (multiple-value-bind (int-value dec-value)
        (floor value)
      (setf dec-value (coerce dec-value 'float))
      (format nil "~a~a"
              (if thousand-separator
                  (string-trim " " (format nil integer-control-string thousand-separator int-value))
                  (format nil integer-control-string int-value))
              (cond
                ((and (= 0.0 (coerce dec-value 'double-float)) decimal-digits)
                 (format nil "~a~a" decimals-separator (make-string decimal-digits :initial-element #\0)))
                (decimal-digits
                 (let ((frac-part (subseq (format nil "~f" dec-value) 2)))
                   (if (> (length frac-part) decimal-digits)
                       (setf frac-part (subseq frac-part 0 decimal-digits))
                       (setf frac-part (concatenate 'string frac-part (make-string (- decimal-digits (length frac-part)) :initial-element #\0))))
                   (format nil "~a~a" decimals-separator frac-part)))
                (t (format nil "~a~a" decimals-separator (subseq (format nil "~f" dec-value) 2))))))))

(defmethod translator-value-decode ((translator translator-number) value &optional client-id label)
  (let ((thousand-separator (translator-thousand-separator translator))
        (type (translator-coerce translator))
        (new-value))
    (if thousand-separator
        (setf new-value (regex-replace-all (format nil "~a" thousand-separator) value ""))
        (setf new-value value))
    (handler-case
        (let* ((decomposed-string (all-matches-as-strings "[0-9]+" new-value))
               (int-value (parse-integer (concatenate 'string (first decomposed-string) (second decomposed-string))))
               (dec-value (expt 10 (length (second decomposed-string))))
               (result (/ int-value dec-value)))
          (if (integerp result)
              result
              (coerce result type)))
      (error () (progn
                  (when label
                    (add-validation-error client-id (format nil (or (validation-error-control-string translator)
                                                                    "Field ~a is not a valid number.") label)))
                  value)))))


(defvar *number-translator* 
  (make-instance 'translator-number)
  "Default instance for TRANSLATOR-NUMBER class")
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;; Dates translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass translator-date (translator)
  ((local-time-format :initarg :local-time-format
                      :reader translator-local-time-format
                      :documentation "Sets the format of a date using a list where element are joined together and :DATE :MONTH and :YEAR are
expanded into day of the month for :DATE, month number for :MONTH and the year for :YEAR. The Default is the list '(:month \"/\" :date \"/\" :year)"))
  (:default-initargs :local-time-format '(:year "-" :month "-" :date))
  (:documentation "A translator object encodes and decodes local-date object value passed to a html input component.
When decoding the input compoenent value string to a local-time instance
if the date is expressed in a wrong format or is not valid, a localizable message \"Field ~a is not a valid date or wrong format: ~a\" is sent with key \"VALIDATE-DATE\".
The argument for the message will be the :label attribute of the COMPONENT and the input component string value."))



(defmethod translator-value-encode ((translator translator-date) value)
  (let* ((local-time-format (translator-local-time-format translator)))
    (if (and value (not (stringp value)))
        (local-time-to-string value local-time-format)
        value)))

(defmethod translator-value-decode ((translator translator-date) value &optional client-id label)
  (let ((date-format (translator-local-time-format translator))
        (sec 0)
        (min 0)
        (hour 0)
        (day 1)
        (month 1)
        (year 0)
        (old-value))
    (when (and value (string-not-equal value ""))
      (setf old-value value)
      (loop for element in date-format
         do (if (stringp element)
                (setf value (subseq value (length element)))
                (ccase element
                  (:second (multiple-value-bind (curr-value size)
                               (parse-integer value :junk-allowed t)
                             (setf value (subseq value size))
                             (setf sec curr-value)))
                  (:minute (multiple-value-bind (curr-value size)
                               (parse-integer value :junk-allowed t)
                             (setf value (subseq value size))
                             (setf min curr-value)))
                  (:hour (multiple-value-bind (curr-value size)
                             (parse-integer value :junk-allowed t)
                           (setf value (subseq value size))
                           (setf hour curr-value)))
                  (:date (multiple-value-bind (curr-value size)
                             (parse-integer value :junk-allowed t)
                           (setf value (subseq value size))
                           (setf day curr-value)))
                  (:month (multiple-value-bind (curr-value size)
                              (parse-integer value :junk-allowed t)
                            (setf value (subseq value size))
                            (setf month curr-value)))
                  (:year (multiple-value-bind (curr-value size)
                             (parse-integer value :junk-allowed t)
                           (setf value (subseq value size))
                           (setf year curr-value))))))
      (if (and (string-equal value "")
               (>= sec 0)
               (>= min 0)
               (>= hour 0)
               (and (> month 0) (<= month 12))
               (and (> day 0) (<= day (days-in-month month year))))
          (encode-local-time 0 sec min hour day month year)
          (progn
            (when label
              (add-validation-error client-id (format nil (or (validation-error-control-string translator)
                                                              "Field ~a is not a valid date or wrong format.") label)))
            value)))))

(defvar *date-translator-ymd*
  (make-instance 'translator-date)
  "Default instance for TRANSLATOR-DATE class")

(defvar *date-translator-time* 
  (make-instance 'translator-date :local-time-format '("T" :hour ":" :minute ":" :second))
  "Default instance for TRANSLATOR-DATE class.
  :LOCAL-TIME-FORMAT is '(\"T\" :HOUR \":\" :MINUTE \":\" :SECOND)
")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;; Boolean translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass translator-boolean (translator)
  ()
  (:documentation "a translator object encodes and decodes boolean values passed to a html input component"))

(defmethod translator-value-encode ((translator translator-boolean) value)
  (format nil "~a" value))

(defmethod translator-value-decode ((translator translator-boolean) value &optional client-id label)
  (declare (ignore client-id label))
  (if (string-equal value "NIL")
      nil
      t))

(defvar *boolean-translator*
  (make-instance 'translator-boolean)
  "Default instance for BOOLEAN-TRANSLATOR class")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;; File translator ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defclass translator-file (translator)
  ()
  (:documentation "a translator object encodes and decodes file values passed to a html input component of type file"))

(defmethod translator-value-encode ((translator translator-file) value)
  (cond
    ((null value) "")
    ((stringp value) value)
    ((pathnamep value) (format nil "~a.~a"
                               (pathname-name value)
                               (pathname-type value)))
    (t (second value))))

(defmethod translator-value-decode ((translator translator-file) value &optional client-id label)
  (declare (ignore client-id label))
  value)

(setf *file-translator* (make-instance 'translator-file))