Added iso date code parser/encoder

isodate.lisp

@@ -0,0 +1,160 @@
+;;;; isodate.lisp
+
+(defpackage #:iso-date
+  (:use :cl
+        :esrap)
+  (:export #:parse-date
+           #:print-date))
+
+(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))
+  (parse 'whole date))
+
+(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)))