(in-package :kira)

(defun render-date (dt)
  (if *allow-elements-p*
      (html ((:span :title dt) (print-date dt *html-output*)))
      (print-date dt *html-output*)))

(defun render-time (dt)
  (if *allow-elements-p*
      (html ((:span :title dt) (print-time dt *html-output*)))
      (print-time dt *html-output*)))

(defun render-date-time (dt)
  (if *allow-elements-p*
      (html ((:span :title dt) (print-date-time dt *html-output*)))
      (print-date-time dt *html-output*)))

(definput date-field (name value &key id onchange)
  (text-field
   name
   (when value
     (let ((*print-time* nil))
       (princ-to-string value)))
   :id id
   :size 10
   :maxlength t
   :onchange onchange))

(definput date-time-field (name value &key onchange)
  (date-field name value :onchange onchange)
  (html " ")
  (text-field
   (format nil "(time ~a)" name)
   (and value (print-time value nil))
   :size 8
   :maxlength t))

(defmacro with-tokens ((string) &body body)
  (with-unique-names (start end)
    (rebinding (string)
      `(let ((,start 0)
	     (,end 0))
	 (flet ((read-integer-token ()
		  (when (and ,end (setf ,start (position-if #'digit-char-p ,string :start ,end)))
		    (setf ,end (position-if-not #'digit-char-p ,string :start ,start))
		    (parse-integer (subseq ,string ,start ,end)))))
	   ,@body)))))

(defmethod string->type (date (type (eql 'date)))
  (with-tokens (date)
    (whereas ((year (read-integer-token)))
      (make-date-time
       :year year
       :month (read-integer-token)
       :day (read-integer-token)))))

(defmethod parse-parameter (name (type (eql 'date-time)))
  (whereas ((dt (parse-parameter name 'date)))
    (prog1 dt
      (whereas ((time (request-query-value (format nil "(time ~a)" name))))
	(with-tokens (time)
	  (let ((hour (read-integer-token))
		(minute (read-integer-token))
		(second (read-integer-token)))
	    (cond
	      ((search "AM" time :test #'char-equal)
	       (when (= hour 12)
		 (setf hour 0)))
	      ((search "PM" time :test #'char-equal)
	       (when (< hour 12)
		 (incf hour 12)))
	      (t
	       (setf (date-time-utc-p dt) t)))
	    (when hour
	      (setf (date-time-hour dt) hour
		    (date-time-minute dt) minute))))))))