misc-code/isodate.lisp

;;;; isodate.lisp

(defpackage #:iso-date
  (:use :cl
        :esrap)
  (:export #:parse-date
           #:print-date
           #:date-stamp))

(in-package #:iso-date)

;;; "isodate" goes here. Hacks and glory await!

(define-condition month-error (error)
  ((month :initarg :month)))

(define-condition date-error (error)
  ((month :initarg :month)
   (date :initarg :date)))

(define-condition hour-error (error)
  ((hour :initarg :hour)))

(define-condition minute-error (error)
  ((minute :initarg :minute)))

(define-condition second-error (error)
  ((second :initarg :second)))

(defrule year
    (and (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0")
       (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0")
       (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0")
       (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0"))
  (:text t)
  (:lambda (text)
    (parse-integer text)))

(defrule month
    (and (or "0" "1")
       (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0"))
  (:text t)
  (:lambda (text)
    (parse-integer text)))

(defrule day
    (and (or "0" "1" "2" "3")
       (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0"))
  (:text t)
  (:lambda (text)
    (parse-integer text)))

(defrule hour
    (and (or "0" "1" "2")
       (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
  (:text t)
  (:lambda (text)
    (parse-integer text)))

(defrule minute
    (and (or "0" "1" "2" "3" "4" "5")
       (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0"))
  (:text t)
  (:lambda (text)
    (parse-integer text)))

(defrule second
    (and (or "0" "1" "2" "3" "4" "5")
       (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0"))
  (:text t)
  (:lambda (text)
    (parse-integer text)))

(defun leap-year-p (year)
  (or (= (mod year 4) 0)
     (= (mod year 100) 0)
     (= (mod year 400) 0)))

(defrule whole-date
    (and year (? (and "-" month (? (and "-" day)))))
  (:destructure (year (d month (dd day)))
                (declare (ignore d dd)
                         (ignorable year month day))
                (assert (or (null month)
                           (<= month 12))
                        (month)
                        'month-error :month month)
                (assert (or (null day)
                           (and (leap-year-p year)
                              (= month 2)
                              (= day 29))
                           (and (= month 1)
                              (<= day 31))
                           (and (= month 2)
                              (<= day 28))
                           (and (= month 3)
                              (<= day 31))
                           (and (= month 4)
                              (<= day 30))
                           (and (= month 5)
                              (<= day 31))
                           (and (= month 6)
                              (<= day 30))
                           (and (= month 7)
                              (<= day 31))
                           (and (= month 8)
                              (<= day 31))
                           (and (= month 9)
                              (<= day 30))
                           (and (= month 10)
                              (<= day 31))
                           (and (= month 11)
                              (<= day 30))
                           (and (= month 12)
                              (<= day 31)))
                        (day year month)
                        'date-error :year year :month month :day day)
                (let ((month (if (null month) 0 month))
                      (day (if (null day) 0 day)))
                  (list year month day))))

(defrule whole-time
    (and hour ":" minute ":" second)
  (:destructure (hour c minute cc second)
                (declare (ignore c cc))
                (assert (<= hour 24)
                        (hour)
                        'hour-error :hour hour)
                (assert (<= minute 59)
                        (minute)
                        'minute-error :minute minute)
                (assert (<= second 59)
                        (second)
                        'second-error :second second)
                (list hour minute second)))

(defrule whole
    (and whole-date (? (and "T" whole-time)))
  (:lambda (list)
    (let ((year (first (first list)))
          (month (second (first list)))
          (day (third (first list)))
          (hour (first (second (second list))))
          (minute (second (second (second list))))
          (second (third (second (second list)))))
      (let ((hour (if (null hour) 0 hour))
            (minute (if (null minute) 0 minute))
            (second (if (null second) 0 second)))
        (encode-universal-time second minute hour day month year)))))

(defun parse-date (date)
  (declare (string date))
  (let ((date (parse 'whole date)))
    (multiple-value-bind (second minute hour date month year day daylight-p zone) (decode-universal-time date)
      (declare (ignorable day daylight-p zone))
      (values date
              (list second minute hour date month year)))))

(defun print-date (date)
  (declare (integer date))
  (multiple-value-bind (second minute hour date month year day daylight-p zone) (decode-universal-time date)
    (declare (ignorable day daylight-p zone))
    (format nil "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d"
            year month date
            hour minute second)))

(defun date-stamp ()
  (values (print-date (get-universal-time))
          (get-universal-time)))