Fix setters for date types.

3 files changed, 51 insertions, 20 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 ...)
diff --git a/main.scm b/main.scm
index 9469e955..87be8bdf 100755
--- a/main.scm
+++ b/main.scm
@@ -4,11 +4,11 @@
 
 (add-to-load-path ".")
 
-(load "code.scm")
 (use-modules (srfi srfi-1)
              (srfi srfi-19)
              (srfi srfi-26)
-             (vcalendar))
+             (vcalendar)
+             (code))
 
 ;;; ------------------------------------------------------------
 
@@ -29,8 +29,9 @@
   (cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev)))
                              (children cal))))
          (find (lambda (ev) (string-contains-ci (car ev) term))
-               (map-cons (cut get-attr <> "SUMMARY")
-                         events)))))
+               (map cons (map (cut get-attr <> "SUMMARY")
+                              events)
+                    events)))))
 
 
 (define (main args)
@@ -54,5 +55,4 @@
                                (get-attr ev "SUMMARY")))))
 
 
-k
   #; (define pizza-event (search cal "pizza"))
diff --git a/srfi/srfi-19/setters.scm b/srfi/srfi-19/setters.scm
new file mode 100644
index 00000000..147cb6c0
--- /dev/null
+++ b/srfi/srfi-19/setters.scm
@@ -0,0 +1,15 @@
+(define-module (srfi srfi-19 setters) 
+  #:use-module (srfi srfi-19)           ; Date/Time
+  ;; (record-type-fields (@@ (srfi srfi-19) date))
+  #:export (nanosecond second minute hour day month year zone-offset))
+
+
+(define nanosecond (make-procedure-with-setter (@ (srfi srfi-19) date-nanosecond) (@@ (srfi srfi-19) set-date-nanosecond!)))
+(define second (make-procedure-with-setter (@ (srfi srfi-19) date-second) (@@ (srfi srfi-19) set-date-second!)))
+(define minute (make-procedure-with-setter (@ (srfi srfi-19) date-minute) (@@ (srfi srfi-19) set-date-minute!)))
+(define hour (make-procedure-with-setter (@ (srfi srfi-19) date-hour) (@@ (srfi srfi-19) set-date-hour!)))
+(define day (make-procedure-with-setter (@ (srfi srfi-19) date-day) (@@ (srfi srfi-19) set-date-day!)))
+(define month (make-procedure-with-setter (@ (srfi srfi-19) date-month) (@@ (srfi srfi-19) set-date-month!)))
+(define year (make-procedure-with-setter (@ (srfi srfi-19) date-year) (@@ (srfi srfi-19) set-date-year!)))
+(define zone-offset (make-procedure-with-setter (@ (srfi srfi-19) date-zone-offset) (@@ (srfi srfi-19) set-date-zone-offset!)))
+