Fix setters for date types.

1 files changed, 31 insertions, 15 deletions

diff --git a/code.scm b/code.scm
index bbfc6e9a..eba732bc 100755
--- a/code.scm
+++ b/code.scm
@@ -1,6 +1,10 @@
-(add-to-load-path (dirname (current-filename)))
+(define-module (code)
+  #:export (extract localize-date sort* drop-time! copy-date
+                    drop-time %date<=? date-today? color-if
+                    for-each-in STR-YELLOW STR-RESET))
 
 (use-modules (srfi srfi-19)
+             (srfi srfi-19 setters)
              (srfi srfi-26)
              (vcalendar))
 
@@ -21,22 +25,34 @@
 (define STR-YELLOW "\x1b[0;33m")
 (define STR-RESET "\x1b[m")
 
+(define (drop-time! date)
+  (set! (hour date) 0)
+  (set! (minute date) 0)
+  (set! (second date) 0)
+  (set! (nanosecond date) 0)
+  date)
+
+(define (copy-date date)
+  (let* ((date-type (@@ (srfi srfi-19) date))
+         (access (lambda (field) ((record-accessor date-type field) date))))
+    (apply make-date (map access (record-type-fields date-type)))))
+
+(define (drop-time date)
+  (let ((new-date (copy-date date)))
+    (drop-time! new-date)))
+
+(define (%date<=? a b)
+  (time<=? (date->time-utc a)
+           (date->time-utc b)))
+
 (define (date-today? input-date)
   (let* ((date (current-date))
-         (now (make-date 0 0 0 0
-                         (date-day date)
-                         (date-month date)
-                         (date-year date)
-                         (date-zone-offset date)))
-         (then (make-date 0 0 0 0
-                          (1+ (date-day date))
-                          (date-month date)
-                          (date-year date)
-                          (date-zone-offset date))))
-    (and (time<=? (date->time-utc now)
-                  (date->time-utc input-date))
-         (time<=? (date->time-utc input-date)
-                  (date->time-utc then)))))
+         (now (drop-time date))
+         (then (copy-date now)))
+    (set! (day then)
+          (1+ (day then)))
+    (and (%date<=? now input-date)
+         (%date<=? input-date then))))
 
 
 (define-syntax-rule (color-if pred color body ...)