Move datetime stuff to better suited files.

4 files changed, 76 insertions, 44 deletions

diff --git a/code.scm b/code.scm
index 14581c90..d7167c92 100755
--- a/code.scm
+++ b/code.scm
@@ -1,21 +1,16 @@
 (define-module (code)
-  #:export (extract localize-date sort* drop-time! copy-date
-                    drop-time %date<=? date-today? color-if
+  #:export (extract sort* color-if
                     for-each-in STR-YELLOW STR-RESET
                     print-vcomponent))
 
 (use-modules (srfi srfi-19)
-             (srfi srfi-19 setters)
+             (srfi srfi-19 util)
              (srfi srfi-26)
              (vcalendar))
 
 (define (extract field)
   (cut get-attr <> field))
 
-(define (localize-date date)
-  (time-utc->date (date->time-utc date)
-                  (date-zone-offset (current-date))))
-
 ;;; This function borrowed from web-ics (calendar util) 
 (define* (sort* items comperator #:optional (get identity))
   "A sort function more in line with how python's sorted works"
@@ -26,35 +21,6 @@
 (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 (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 ...)
   (let ((pred-value pred))
diff --git a/main.scm b/main.scm
index 87be8bdf..181e7f90 100755
--- a/main.scm
+++ b/main.scm
@@ -6,8 +6,10 @@
 
 (use-modules (srfi srfi-1)
              (srfi srfi-19)
+             (srfi srfi-19 util)
              (srfi srfi-26)
              (vcalendar)
+             (vcalendar datetime)
              (code))
 
 ;;; ------------------------------------------------------------
@@ -16,14 +18,7 @@
 ;;; Parse all start times into scheme date objects.
   (for-each-in (children cal 'VEVENT)
                (cut transform-attr! <> "DTSTART"
-                    (lambda (start)
-                      (localize-date
-                        (string->date
-                          start
-                          (case (string-length start)
-                            ((8) "~Y~m~d")
-                            ((15) "~Y~m~dT~H~M~S")
-                            ((16) "~Y~m~dT~H~M~S~z"))))))))
+                    parse-datetime)))
 
 (define (search cal term)
   (cdr (let ((events (filter (lambda (ev) (eq? 'VEVENT (type ev)))
diff --git a/srfi/srfi-19/util.scm b/srfi/srfi-19/util.scm
new file mode 100644
index 00000000..777f39f2
--- /dev/null
+++ b/srfi/srfi-19/util.scm
@@ -0,0 +1,55 @@
+(define-module (srfi srfi-19 util)
+  #:use-module (srfi srfi-9 gnu)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-19 setters)
+  #:export (copy-date
+            drop-time! drop-time
+            localize-date
+            date-today?))
+
+(define (copy-date date)
+  "Returns a copy of the given date structure"
+  (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)
+  "Sets the hour, minute, second and nanosecond attribute of date to 0."
+  (set! (hour date) 0)
+  (set! (minute date) 0)
+  (set! (second date) 0)
+  (set! (nanosecond date) 0)
+  date)
+
+(define (drop-time date)
+  "Returns a copy of date; with the hour, minute, second and nanosecond
+attribute set to 0."
+  #; 
+  (let ((new-date (copy-date date)))    ;
+  (drop-time! new-date))
+  (set-fields date
+              ((date-hour) 0)
+              ((date-minute) 0)
+              ((date-second) 0)
+              ((date-nanosecond) 0)))
+
+
+(define (%date<=? a b)
+  (time<=? (date->time-utc a)
+           (date->time-utc b)))
+
+(define (localize-date date)
+  "Returns a <date> object representing the same datetime as `date`, but
+transposed to the current timezone. Current timezone gotten from
+(current-date)."
+  (time-utc->date (date->time-utc date)
+                  (date-zone-offset (current-date))))
+
+(define (date-today? input-date)
+  (let* ((date (current-date))
+         (now (drop-time date))
+         (then (copy-date now)))
+    (set! (day then)
+          (1+ (day then)))
+    (and (%date<=? now input-date)
+         (%date<=? input-date then))))
diff --git a/vcalendar/datetime.scm b/vcalendar/datetime.scm
new file mode 100644
index 00000000..af8382c8
--- /dev/null
+++ b/vcalendar/datetime.scm
@@ -0,0 +1,16 @@
+(define-module (vcalendar datetime)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-19 util)
+
+  #:export (parse-datetime)
+  )
+
+(define (parse-datetime dtime)
+  "Parse the given date[time] string into a date object."
+  (localize-date
+   (string->date
+    dtime
+    (case (string-length dtime)
+      ((8) "~Y~m~d")
+      ((15) "~Y~m~dT~H~M~S")
+      ((16) "~Y~m~dT~H~M~S~z")))))