isodate.lisp 6.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194
  1. ;;;; isodate.lisp
  2. (defpackage #:iso-date
  3. (:use :cl
  4. :esrap)
  5. (:export #:parse-date
  6. #:print-date
  7. #:date-stamp
  8. #:parse-mini-date
  9. #:print-mini-date
  10. #:mini-date-stamp))
  11. (in-package #:iso-date)
  12. ;;; "isodate" goes here. Hacks and glory await!
  13. (define-condition month-error (error)
  14. ((month :initarg :month)))
  15. (define-condition date-error (error)
  16. ((month :initarg :month)
  17. (date :initarg :date)))
  18. (define-condition hour-error (error)
  19. ((hour :initarg :hour)))
  20. (define-condition minute-error (error)
  21. ((minute :initarg :minute)))
  22. (define-condition second-error (error)
  23. ((second :initarg :second)))
  24. (defrule year
  25. (and (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0")
  26. (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0")
  27. (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0")
  28. (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0"))
  29. (:text t)
  30. (:lambda (text)
  31. (parse-integer text)))
  32. (defrule month
  33. (and (or "0" "1")
  34. (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0"))
  35. (:text t)
  36. (:lambda (text)
  37. (parse-integer text)))
  38. (defrule day
  39. (and (or "0" "1" "2" "3")
  40. (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0"))
  41. (:text t)
  42. (:lambda (text)
  43. (parse-integer text)))
  44. (defrule hour
  45. (and (or "0" "1" "2")
  46. (or "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))
  47. (:text t)
  48. (:lambda (text)
  49. (parse-integer text)))
  50. (defrule minute
  51. (and (or "0" "1" "2" "3" "4" "5")
  52. (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0"))
  53. (:text t)
  54. (:lambda (text)
  55. (parse-integer text)))
  56. (defrule second
  57. (and (or "0" "1" "2" "3" "4" "5")
  58. (or "1" "2" "3" "4" "5" "6" "7" "8" "9" "0"))
  59. (:text t)
  60. (:lambda (text)
  61. (parse-integer text)))
  62. (defun leap-year-p (year)
  63. (or (= (mod year 4) 0)
  64. (= (mod year 100) 0)
  65. (= (mod year 400) 0)))
  66. (defrule whole-date
  67. (and year (? (and "-" month (? (and "-" day)))))
  68. (:destructure (year (d month (dd day)))
  69. (declare (ignore d dd)
  70. (ignorable year month day))
  71. (assert (or (null month)
  72. (<= month 12))
  73. (month)
  74. 'month-error :month month)
  75. (assert (or (null day)
  76. (and (leap-year-p year)
  77. (= month 2)
  78. (= day 29))
  79. (and (= month 1)
  80. (<= day 31))
  81. (and (= month 2)
  82. (<= day 28))
  83. (and (= month 3)
  84. (<= day 31))
  85. (and (= month 4)
  86. (<= day 30))
  87. (and (= month 5)
  88. (<= day 31))
  89. (and (= month 6)
  90. (<= day 30))
  91. (and (= month 7)
  92. (<= day 31))
  93. (and (= month 8)
  94. (<= day 31))
  95. (and (= month 9)
  96. (<= day 30))
  97. (and (= month 10)
  98. (<= day 31))
  99. (and (= month 11)
  100. (<= day 30))
  101. (and (= month 12)
  102. (<= day 31)))
  103. (day year month)
  104. 'date-error :year year :month month :day day)
  105. (let ((month (if (null month) 0 month))
  106. (day (if (null day) 0 day)))
  107. (list year month day))))
  108. (defrule whole-time
  109. (and hour ":" minute ":" second)
  110. (:destructure (hour c minute cc second)
  111. (declare (ignore c cc))
  112. (assert (<= hour 24)
  113. (hour)
  114. 'hour-error :hour hour)
  115. (assert (<= minute 59)
  116. (minute)
  117. 'minute-error :minute minute)
  118. (assert (<= second 59)
  119. (second)
  120. 'second-error :second second)
  121. (list hour minute second)))
  122. (defrule whole
  123. (and whole-date (? (and "T" whole-time)))
  124. (:lambda (list)
  125. (let ((year (first (first list)))
  126. (month (second (first list)))
  127. (day (third (first list)))
  128. (hour (first (second (second list))))
  129. (minute (second (second (second list))))
  130. (second (third (second (second list)))))
  131. (let ((hour (if (null hour) 0 hour))
  132. (minute (if (null minute) 0 minute))
  133. (second (if (null second) 0 second)))
  134. (encode-universal-time second minute hour day month year)))))
  135. (defun parse-date (date)
  136. (declare (string date))
  137. (let ((date (parse 'whole date)))
  138. (multiple-value-bind (second minute hour date month year day daylight-p zone) (decode-universal-time date)
  139. (declare (ignorable day daylight-p zone))
  140. (values date
  141. (list second minute hour date month year)))))
  142. (defun print-date (date)
  143. (declare (integer date))
  144. (multiple-value-bind (second minute hour date month year day daylight-p zone) (decode-universal-time date)
  145. (declare (ignorable day daylight-p zone))
  146. (values (format nil "~4,'0d-~2,'0d-~2,'0dT~2,'0d:~2,'0d:~2,'0d"
  147. year month date
  148. hour minute second)
  149. date)))
  150. (defun date-stamp ()
  151. (values (print-date (get-universal-time))
  152. (get-universal-time)))
  153. (defrule minidate
  154. (and year (? (and month (? (and day (? (and hour minute second)))))))
  155. (:destructure (year (month (day (&optinal hour minute second))))
  156. (declare (ignorable month day hour minute second))
  157. (if (null month)
  158. (encode-universal-time 0 0 0 1 1 year)
  159. (if (null day)
  160. (encode-universal-time 0 0 0 1 month year)
  161. (if (null hour)
  162. (encode-universal-time 0 0 0 day month year)
  163. (encode-universal-time second minute hour day month year))))))
  164. (defun parse-mini-date (date)
  165. (declare (string date))
  166. (values (parse 'minidate date)
  167. date))
  168. (defun print-mini-date (date))
  169. (defun mini-date-stamp ())