(in-package :date-time)

(defstruct (date-time (:print-function print-date-time/iso-8601))
  year
  month
  day
  hour
  minute
  second
  utc-p)

(defun ut-to-date-time (ut &optional (dt (make-date-time)) (utc-p t))
  (prog1 dt
    (multiple-value-bind (second minute hour day month year) (decode-universal-time ut 0)
      (setf (date-time-year dt) year
	    (date-time-month dt) month
	    (date-time-day dt) day
	    (date-time-hour dt) hour
	    (date-time-minute dt) minute
	    (date-time-second dt) second
	    (date-time-utc-p dt) utc-p))))

(defun now (&optional (utc-p t))
  (ut-to-date-time (get-universal-time) (make-date-time) utc-p))

(defun date-time-to-ut (dt)
  (encode-universal-time
   (or (date-time-second dt) 0)
   (or (date-time-minute dt) 0)
   (or (date-time-hour dt) 0)
   (or (date-time-day dt) 0)
   (or (date-time-month dt) 0)
   (or (date-time-year dt) 0)
   0))

(defun date-time-day-of-the-week (dt)
  (nth-value 6 (decode-universal-time (date-time-to-ut dt) 0)))

(defun merge-date-times (dt default)
  (macrolet ((maybe-fill-in (component)
               `(unless (,component dt)
		  (setf (,component dt) (,component default)))))
    (maybe-fill-in date-time-year)
    (maybe-fill-in date-time-month)
    (maybe-fill-in date-time-day)
    (maybe-fill-in date-time-hour)
    (maybe-fill-in date-time-minute)
    (maybe-fill-in date-time-second)
    dt))

(defvar *print-time* t)
(defvar *print-separators* t)

(defun print-date-time/iso-8601 (dt stream depth)
  (declare (ignore depth))
  (when (eq (date-time-year dt) nil)
    (return-from print-date-time/iso-8601 (prin1 nil stream)))
  (macrolet ((print-component (prefix component width)
	       `(whereas ((c (or (,component dt) (return))))
		  (when (and ,prefix *print-separators*)
		    (write-char ,prefix stream))
		  (format stream ,(format nil "~~~d,'0d" width) c))))
    (when *print-escape*
      (write-char #\@ stream))
    (block nil
      (print-component nil date-time-year 4)
      (print-component #\- date-time-month 2)
      (print-component #\- date-time-day 2)
      (when *print-time*
	(let ((*print-separators* t))
	  (print-component #\T date-time-hour 2))
	(print-component #\: date-time-minute 2)
	(print-component #\: date-time-second 2)))
    (when (and *print-time* (date-time-utc-p dt))
      (write-char #\Z stream))))

(defun read-fixed-width-integer (stream width)
  (loop with result = nil
        repeat width
        for char = (peek-char nil stream nil #\x)
        for digit = (digit-char-p char)
        while digit do (read-char stream)
        (setf result (if result (+ (* result 10) digit) digit))
	finally (return result)))

(defun read-component-following-char (stream prefix width &optional optional-prefix-p)
  (whereas ((char (peek-char nil stream nil nil)))
    (when (or (eq prefix nil)
	      (and (char-equal char prefix) (read-char stream))
	      optional-prefix-p)
      (read-fixed-width-integer stream width))))

(defun read-date-time (stream)
  (let ((dt (make-date-time)))
    (macrolet ((read-component (prefix component width &optional (optional-prefix-p t))
                 `(setf (,component dt)
			(or (read-component-following-char stream ,prefix ,width ,optional-prefix-p)
			    (return)))))
      (block nil
        (read-component nil date-time-year 4)
        (read-component #\- date-time-month 2)
        (read-component #\- date-time-day 2)
        (read-component #\T date-time-hour 2 nil)
        (read-component #\: date-time-minute 2)
        (read-component #\: date-time-second 2)))
    (case (peek-char nil stream nil nil)
      ((#\, #\.)
       (read-char stream)
       ;; Discard fractional seconds.
       (loop for char = (peek-char nil stream nil #\x)
	     while (digit-char-p char)
	     do (read-char stream))))
    (prog1 dt
      (case (peek-char nil stream nil nil)
	((#\Z #\z)
	 (read-char stream)
	 (setf (date-time-utc-p dt) t))
	((#\- #\+)
	 (whereas ((operator #'+)
		   (hour-offset
		    (or (read-component-following-char stream #\- 2)
			(and (read-component-following-char stream #\+ 2)
			     (setf operator #'-))))
		   (minute-offset
		    (or (read-component-following-char stream #\: 2 t) 0)))
	   (ut-to-date-time
	    (funcall
	     operator
	     (date-time-to-ut dt)
	     (* hour-offset 3600)
	     (* minute-offset 60))
	    dt)))))))

(set-macro-character
 #\@
 (lambda (stream char)
   (declare (ignore char))
   (read-date-time stream)))

(defmethod compare-objects ((a date-time) (b date-time))
  (macrolet ((compare-components (component)
               `(let ((c1 (,component a))
		      (c2 (,component b)))
		  (when (or c1 c2)
		    (when (not c1)
		      (return -1))
		    (when (not c2)
		      (return 1))
		    (when (< c1 c2)
		      (return -1))
		    (when (> c1 c2)
		      (return 1))))))
    (block nil
      (compare-components date-time-year)
      (compare-components date-time-month)
      (compare-components date-time-day)
      (compare-components date-time-hour)
      (compare-components date-time-minute)
      (compare-components date-time-second)
      (return 0))))

(defconstant +months+
  #("Nilember" "January" "February" "March" "April" "May" "June" "July" "August"
    "September" "October" "November" "December"))

(defconstant +days+
  #("Monday" "Tuesday" "Wednesday" "Thursday" "Friday" "Saturday" "Sunday"))

(defun month-number (string)
  (let ((end (if (= (length string) 3) 3 nil)))
    (loop for i below (length +months+)
          when (string-equal (aref +months+ i) string :end1 end)
	  return i)))

(defun month-name (number)
  (when (and (integerp number) (>= number 1) (<= number 12))
    (aref +months+ number)))

(defun classify-time (dt)
  (whereas ((hour (date-time-hour dt))
	    (minute (or (date-time-minute dt) 0))
	    (second (or (date-time-second dt) 0)))
    (if (date-time-utc-p dt)
	(values hour minute :utc)
	(values (cond ((= hour 0) 12)
		      ((>= hour 13) (- hour 12))
		      (t hour))
		minute
		(if (and (>= hour 12) (< hour 24))
		    :pm
		    :am)))))

(defun print-date (dt &optional (stream t))
  (with-output (stream)
    (whereas ((day (date-time-day dt)))
      (princ day stream)
      (write-char #\space stream))
    (whereas ((month (month-name (date-time-month dt))))
      (write-string month stream :end 3)
      (write-char #\space stream))
    (whereas ((year (date-time-year dt)))
      (princ year stream))))

(defun print-time (dt &optional (stream t))
  (with-output (stream)
    (multiple-value-bind (hour minute modifier) (classify-time dt)
      (format stream "~:[~d~;~@[~2,'0d~]~]~@[:~2,'0d~] ~a" (eq modifier :utc) hour minute modifier))))

(defun print-date-time (dt &optional (stream t))
  (with-output (stream)
    (print-date dt stream)
    (when (date-time-hour dt)
      (write-string " at " stream)
      (print-time dt stream))))

(defmethod string->type (string (type (eql 'date-time)))
  (with-input-from-string (stream string)
    (read-date-time stream)))

(defun print-rfc-822-time (dt &optional (stream t))
  (with-output (stream)
    (write-string (aref +days+ (date-time-day-of-the-week dt)) stream :end 3)
    (format stream ", ~2,'0d " (or (date-time-day dt) 1))
    (write-string (month-name (or (date-time-month dt) 1)) stream :end 3)
    (format stream
	    " ~4,'0d ~2,'0d:~2,'0d:~2,'0d GMT"
	    (or (date-time-year dt) 2000)
	    (or (date-time-hour dt) 0)
	    (or (date-time-minute dt) 0)
	    (or (date-time-second dt) 0))))

(defmethod string->type (string (type (eql 'rfc-822-time)))
  (whereas ((start (position-if #'digit-char-p string))
	    (month-name (copy-seq "Mon")))
    (with-input-from-string (stream string :start start)
      (whereas ((day (read-fixed-width-integer stream 2))
		(month (loop for i below 3
			     for char = (peek-char t stream nil nil)
			     then (peek-char nil stream nil nil)
			     while char do (setf (aref month-name i) (read-char stream))
			     finally (return (month-number month-name))))
		(year (progn
			(peek-char t stream nil nil)
			(read-fixed-width-integer stream 4)))
		(hour (progn
			(peek-char t stream nil nil)
			(read-fixed-width-integer stream 2)))
		(minute (read-component-following-char stream #\: 2))
		(second (read-component-following-char stream #\: 2)))
	(make-date-time
	 :year year
	 :month month
	 :day day
	 :hour hour
	 :minute minute
	 :second second
	 :utc-p t)))))