From 30357bc117aee20b7f43ec40fe5551930a0bf7d3 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@hornquist.se>
Date: Fri, 14 Feb 2020 00:19:05 +0100
Subject: Add datetime-difference.

---
 module/output/html.scm      |  4 ++--
 module/srfi/srfi-19/alt.scm | 34 ++++++++++++++++++++++++++++++++++
 2 files changed, 36 insertions(+), 2 deletions(-)

(limited to 'module')

diff --git a/module/output/html.scm b/module/output/html.scm
index f30e6338..42290ed9 100644
--- a/module/output/html.scm
+++ b/module/output/html.scm
@@ -120,8 +120,8 @@
                       (partition (lambda (ev)
                                    (or (date? (attr ev 'DTSTART))
                                        (datetime<=? (datetime time: (time hour: 24))
-                                                    (datetime- (attr ev 'DTEND)
-                                                               (attr ev 'DTSTART)))))
+                                                    (datetime-difference (attr ev 'DTEND)
+                                                                         (attr ev 'DTSTART)))))
                                  (stream->list events))))
     ;; (format (current-error-port) "lay-out-day: ~a~%" (date->string date))
     (format (current-error-port) "long=~a, short=~a~%"
diff --git a/module/srfi/srfi-19/alt.scm b/module/srfi/srfi-19/alt.scm
index 09f70190..33a1bc1f 100644
--- a/module/srfi/srfi-19/alt.scm
+++ b/module/srfi/srfi-19/alt.scm
@@ -487,6 +487,40 @@
                            (date day: overflow))
               time: time)))
 
+(define (datetime->srfi-19-date date)
+  ((@ (srfi srfi-19) make-date)
+    0
+    (second (get-time date))
+    (minute (get-time date))
+    (hour (get-time date))
+    (day (get-date date))
+    (month (get-date date))
+    (year (get-date date))
+    0                                   ; TODO TZ
+    ))
+
+(define (srfi-19-date->datetime o)
+  (let ((y ((@ (srfi srfi-19) date-year)   o)))
+    ;; TODO find better way to translate from 1970 to 0, since this WILL
+    ;; cause problems sooner or later.
+   (datetime year:   (if (= 1970 y) 0 y)
+             month:  (let ((m ((@ (srfi srfi-19) date-month) o)))
+                       (if (and (= 1970 y) (= 1 m)) 0 m))
+             day:    (let ((d ((@ (srfi srfi-19) date-day) o)))
+                       (if (and (= 1970 y) (= 1 d)) 0 d))
+             hour:   ((@ (srfi srfi-19) date-hour)   o)
+             minute: ((@ (srfi srfi-19) date-minute) o)
+             second: ((@ (srfi srfi-19) date-second) o)
+             )))
+
+
+(define-public (datetime-difference end start)
+  (let ((t
+         ((@ (srfi srfi-19) time-difference)
+          ((@ (srfi srfi-19) date->time-utc) (datetime->srfi-19-date end))
+          ((@ (srfi srfi-19) date->time-utc) (datetime->srfi-19-date start)))))
+    ((@ (srfi srfi-19) set-time-type!) t (@ (srfi srfi-19) time-utc))
+    (srfi-19-date->datetime ((@ (srfi srfi-19) time-utc->date) t 0))))  ; TODO tz offset
 
 
 ;;; Parsers for vcomponent usage
-- 
cgit v1.2.3