123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198 |
- ;;;; isodate.lisp
- (defpackage #:iso-date
- (:use :cl
- :esrap)
- (:export #:parse-date
- #:print-date
- #:date-stamp
- #:parse-mini-date
- #:print-mini-date
- #:mini-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 day month year day-of-year daylight-p zone) (decode-universal-time date)
- (declare (ignorable day-of-year daylight-p zone))
- (values date
- (list second minute hour day month year)))))
- (defun print-date (date)
- (declare (integer date))
- (multiple-value-bind (second minute hour day-of-month month year day daylight-p zone)
- (decode-universal-time date)
- (declare (ignorable day daylight-p zone))
- (values (format nil "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d"
- year month day-of-month
- hour minute second)
- date)))
- (defun date-stamp ()
- (values (print-date (get-universal-time))
- (get-universal-time)))
- (defrule minidate
- (and year month day (? (and hour minute second)))
- (:destructure (year month day (&optional hour minute second))
- (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-mini-date (date)
- (declare (string date))
- (values (parse 'minidate date)
- date))
- (defun print-mini-date (date)
- (multiple-value-bind (second minute hour day-of-month month year day daylight-p zone)
- (decode-universal-time date)
- (declare (ignorable day daylight-p zone))
- (format nil "~4,'0d~2,'0d~2,'0d~2,'0d~2,'0d~2,'0d"
- year month day-of-month
- hour minute second)))
- (defun mini-date-stamp ()
- (print-mini-date (get-universal-time)))
|