From 39e487e74d4161ef80c23696b50a968b7a349592 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Tue, 14 Nov 2023 04:58:36 +0100
Subject: Tests for vcomponent datetime and create.

---
 tests/unit/vcomponent/create.scm              |  16 ++
 tests/unit/vcomponent/vcomponent-datetime.scm | 270 ++++++++++++++++++++++++--
 2 files changed, 266 insertions(+), 20 deletions(-)

diff --git a/tests/unit/vcomponent/create.scm b/tests/unit/vcomponent/create.scm
index 537ccbe9..8137d723 100644
--- a/tests/unit/vcomponent/create.scm
+++ b/tests/unit/vcomponent/create.scm
@@ -2,6 +2,7 @@
   :use-module ((srfi srfi-1) :select (every))
   :use-module (srfi srfi-64)
   :use-module (srfi srfi-88)
+  :use-module ((hnh util) :select (-> sort*))
   :use-module ((vcomponent base) :select (vcomponent?))
   :use-module ((vcomponent create)
                :select (vcomponent
@@ -18,6 +19,7 @@
                         properties
                         type
                         prop prop*
+                        extract
                         param
                         vline?)))
 
@@ -56,6 +58,20 @@
     ; (test-eq child (car (children ev)))
     ))
 
+(test-group "Component with multiple children"
+  (let ((cal
+         (vcalendar
+          calscale: "GREGORIAN"
+          (list
+           (vevent summary: "Child 1")
+           (vevent summary: "Child 2")))))
+    (test-equal 2 (length (children cal)))
+    (test-equal "GREGORIAN" (-> cal (prop 'CALSCALE)))
+    (let ((ch (sort* (children cal)
+                     string<? (extract 'SUMMARY))))
+      (test-equal "Child 1" (-> ch (list-ref 0) (prop 'SUMMARY)))
+      (test-equal "Child 2" (-> ch (list-ref 1) (prop 'SUMMARY))))))
+
 (test-group "Component with no children, where last elements value is a list"
   (let ((ev (vcomponent 'TEST prop: (list 1 2 3))))
     (test-equal '() (children ev))
diff --git a/tests/unit/vcomponent/vcomponent-datetime.scm b/tests/unit/vcomponent/vcomponent-datetime.scm
index 3d163e7a..de21281c 100644
--- a/tests/unit/vcomponent/vcomponent-datetime.scm
+++ b/tests/unit/vcomponent/vcomponent-datetime.scm
@@ -4,16 +4,23 @@
 ;;; Code:
 
 (define-module (test vcomponent-datetime)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-41)
   :use-module (srfi srfi-64)
   :use-module (srfi srfi-88)
   :use-module (datetime)
+  :use-module ((hnh util) :select (->> sort*))
   :use-module (hnh util lens)
+  :use-module ((datetime zic) :select (read-zoneinfo))
+  :use-module (datetime timespec)
+  :use-module ((vcomponent) :select (vcomponent-equal? extract prop))
   :use-module (vcomponent datetime)
-  :use-module ((vcomponent create) :select (vevent)))
+  :use-module ((vcomponent recurrence) :select (recur-rule))
+  :use-module ((vcomponent create) :select (vevent vtimezone daylight standard)))
 
 
 (test-group "overlapping?"
-  (test-assert "date, date"
+  (test-assert "date, datetime"
     (overlapping?
      (vevent summary: "A"
              dtstart: (date year: 2020 month: jan day: 1)
@@ -22,12 +29,40 @@
              dtstart: (datetime year: 2020 month: apr day: 1 hour: 10)
              dtend:   (datetime year: 2020 month: apr day: 1 hour: 12))))
 
-  ;; (test-assert "date, datetime")
+  (test-assert "date, date"
+    (overlapping?
+     (vevent summary: "A"
+             dtstart: (date year: 2020 month: jan day: 1)
+             dtend:   (date year: 2020 month: jan day: 20))
+     (vevent summary: "B"
+             dtstart: (date year: 2020 month: jan day: 10)
+             dtend:   (date year: 2020 month: feb day: 10))))
 
-  ;; (test-assert "datetime, date")
+  (test-assert "datetime, date"
+    (not
+     (overlapping?
+      (vevent summary: "A"
+              dtstart: (datetime year: 2020 month: apr day: 1 hour: 10)
+              dtend:   (datetime year: 2020 month: apr day: 1 hour: 12))
+      (vevent summary: "B"
+              dtstart: (date year: 2020 month: jan day: 10)
+              dtend:   (date year: 2020 month: feb day: 10)))))
 
-  ;; (test-assert "datetime, datetime")
-  )
+  (test-assert "datetime, datetime"
+    (overlapping?
+     (vevent summary: "A"
+             dtstart: (datetime year: 2020 month: apr day: 1 hour: 10)
+             dtend:   (datetime year: 2020 month: apr day: 1 hour: 12))
+     (vevent summary: "B"
+             dtstart: (datetime year: 2020 month: apr day: 1 hour: 11)
+             dtend:   (datetime year: 2020 month: apr day: 1 hour: 13))))
+
+  (test-assert "Without dtend"
+   (overlapping?
+    (vevent summary: "A"
+            dtstart: (date year: 2020 month: apr day: 1))
+    (vevent summary: "B"
+            dtstart: (datetime year: 2020 month: apr day: 1 hour: 10)))))
 
 (test-group "event-contains?"
   (let* ((dt (datetime year: 2020 month: jan day: 1
@@ -43,8 +78,39 @@
   (test-assert (not (event-zero-length? (vevent dtstart: (datetime)
                                                dtend: (datetime))))))
 
-;; (test-group "ev-time<?")
-;; (test-group "event-length")
+(test-assert "ev-time<?"
+  (ev-time<?
+   (vevent summary: "A"
+           dtstart: (datetime year: 2020 month: apr day: 1 hour: 10))
+   (vevent summary: "B"
+           dtstart: (datetime year: 2020 month: apr day: 1 hour: 11))))
+
+(test-group "event-length"
+  (test-equal "Datetime, with DTEND"
+    (datetime day: 2 hour: 17)
+    (event-length
+     (vevent
+      dtstart: (datetime year: 2020 month: 3 day: 29 hour: 17)
+      dtend:   (datetime year: 2020 month: 4 day:  1 hour: 10))))
+
+  (test-equal "Datetime, without DTEND"
+    (datetime)
+    (event-length
+     (vevent
+      dtstart: (datetime year: 2020 month: 3 day: 29 hour: 17))))
+
+  (test-equal "Date, with DTEND"
+    (date day: 3)
+    (event-length
+     (vevent
+      dtstart: (date year: 2020 month: 3 day: 29)
+      dtend:   (date year: 2020 month: 4 day:  1))))
+
+  (test-equal "Date, without DTEND"
+    (date day: 1)
+    (event-length
+     (vevent
+      dtstart: (date year: 2020 month: 3 day: 29)))))
 
 (test-group "event-length/clamped"
  (let ((ev
@@ -55,28 +121,89 @@
    ;; |-----------------| test interval
    ;;                 |----------| event interval
 
-   (test-equal
-       "Correct clamping"
+   (test-equal "Correct clamping"
      (datetime hour: 7) ; 2020-03-29T17:00 - 2020-03-30T00:00
      (event-length/clamped
       (date year: 2020 month: 3 day: 23) ; a time way before the start of the event
       (date year: 2020 month: 3 day: 29) ; a time slightly after the end of the event
       ev))
 
+   ;; TODO why is this object created?
    (define utc-ev
      (vevent
       dtstart: (datetime year: 2020 month: 3 day: 29 hour: 15 tz: "UTC")
       dtend:   (datetime year: 2020 month: 4 day:  1 hour:  8 tz: "UTC")))
 
-   (test-equal
-       "Correct clamping UTC"
+   (test-equal "Correct clamping UTC"
      (datetime hour: 7)
      (event-length/clamped
       (date year: 2020 month: 3 day: 23)
       (date year: 2020 month: 3 day: 29)
-      ev))))
+      ev)))
+
+ (let ((ev (vevent dtstart: (datetime year: 2020 month: 3 day: 1))))
+   (test-equal
+       (datetime)
+     (event-length/clamped
+      (date year: 2020 month: 3 day: 1)
+      (date year: 2020 month: 3 day: 2)
+      ev
+      ))
+   )
+
+ ;; TODO test with no dtend (datetime)
+ ;; TODO test with no dtend (date)
+
+ ;; TODO test where both dtstart and dtend are date's
+
+ )
+
+(let ((d (date year: 2020 month: jan day: 10)))
+  (test-group "event-length/day"
+
+    ;; TODO shouldn't a check for the correct date be done?
+    (test-equal
+        (time hour: 24)
+      (event-length/day
+       d
+       (vevent dtstart: (date))))
+
+    (test-equal
+        (time)
+      (event-length/day
+       d
+       (vevent dtstart: (datetime))))
+
+    (test-equal "Within day"
+      (time hour: 10)
+      (event-length/day
+       d
+       (vevent dtstart: (datetime date: d hour: 10)
+               dtend: (datetime date: d hour: 20))))
+
+    (test-equal "Ends tommorrow"
+      (time hour: 14)
+      (event-length/day
+       d
+       (vevent dtstart: (datetime date: d hour: 10)
+               dtend: (datetime date: (date+ d (date day: 1)) hour: 20))))
+
+    (test-equal "Started yesterday"
+      (time hour: 10)
+      (event-length/day
+       d
+       (vevent dtstart: (datetime date: (date- d (date day: 1)) hour: 10)
+               dtend: (datetime date: d hour: 10))))
+
+    (test-equal "Starts before date, ends after date"
+      (time hour: 24)
+      (event-length/day
+       d
+       (vevent dtstart: (datetime date: (date- d (date day: 1)) hour: 10)
+               dtend:   (datetime date: (date+ d (date day: 1)) hour: 10))))
 
-;; (test-group "event-length/day")
+    ;; TODO Test invalid cases
+    ))
 
 (test-group "long-event?"
   (test-assert "DTSTART being date is always a long event"
@@ -93,12 +220,115 @@
                          dtend:   (datetime year: 2020 month: 1 day: 2
                                             hour: 1 minute: 1)))))
 
-;; (test-group "really-long-event?")
-;; (test-group "final-spanned-time")
-;; (test-group "events-between")
-;; (test-group "relevant-zone-entry?")
-;; (test-group "relevant-zone-rule?")
-;; (test-group "zoneinfo->vtimezone")
+(test-group "really-long-event?"
+  (test-assert (not (really-long-event?
+                     (vevent dtstart: (date year: 2020 month: jan day: 1)
+                             dtend:   (date year: 2020 month: jan day: 2)))))
+  (test-assert (really-long-event?
+                (vevent dtstart: (date year: 2020 month: jan day: 1)
+                        dtend:   (date year: 2020 month: jan day: 3))))
+  (test-assert (not (really-long-event?
+                     (vevent dtstart: (datetime year: 2020 month: jan day: 1)
+                             dtend:   (datetime year: 2020 month: jan day: 2)))))
+  (test-assert (really-long-event?
+                (vevent dtstart: (datetime year: 2020 month: jan day: 1)
+                        dtend:   (datetime year: 2020 month: jan day: 2 second: 1))))
+  )
+
+(test-group "events-between"
+  (let ((start (date year: 2020 month: jan day: 1))
+        (end   (date year: 2022 month: jan day: 1)))
+    (let ((expected
+           (list (vevent dtstart: (date year: 2020 month: jan day: 1))
+                 (vevent dtstart: (date year: 2021 month: dec day: 31))
+                 (vevent dtstart: (date year: 2022 month: jan day: 1))))
+          (actual
+           (->> (sort*
+                 (list (vevent dtstart: (date year: 2019 month: jan))
+                       (vevent dtstart: (date year: 2019 month: dec day: 31))
+                       (vevent dtstart: (date year: 2020 month: jan day: 1))
+                       (vevent dtstart: (date year: 2021 month: dec day: 31))
+                       (vevent dtstart: (date year: 2022 month: jan day: 1)))
+                 date< (extract 'DTSTART))
+                list->stream
+                (events-between start end)
+                stream->list
+                )))
+      (test-equal (length expected) (length actual))
+      (for-each
+       (lambda (name a b)
+         (test-equal name
+           (prop a 'DTSTART)
+           (prop b 'DTSTART)
+           ))
+       (map number->string (iota 10))
+       expected
+       actual)))
+  )
+
+
+(test-group "zoneinfo->vtimezone"
+  (let* ((zoneinfo-sample
+          "
+# Rule  NAME  FROM  TO    -  IN   ON       AT    SAVE  LETTER/S
+Rule    Swiss 1941  1942  -  May  Mon>=1   1:00  1:00  S
+Rule    Swiss 1941  1942  -  Oct  Mon>=1   2:00  0     -
+Rule    EU    1977  1980  -  Apr  Sun>=1   1:00u 1:00  S
+Rule    EU    1977  only  -  Sep  lastSun  1:00u 0     -
+Rule    EU    1978  only  -  Oct   1       1:00u 0     -
+Rule    EU    1979  1995  -  Sep  lastSun  1:00u 0     -
+Rule    EU    1981  max   -  Mar  lastSun  1:00u 1:00  S
+Rule    EU    1996  max   -  Oct  lastSun  1:00u 0     -
+
+# Zone  NAME           STDOFF      RULES  FORMAT  [UNTIL]
+Zone    Europe/Zurich  0:34:08     -      LMT     1853 Jul 16
+                       0:29:45.50  -      BMT     1894 Jun
+                       1:00        Swiss  CE%sT   1981
+                       1:00        EU     CE%sT
+
+Link    Europe/Zurich  Europe/Vaduz
+")
+
+         (zoneinfo
+          (call-with-input-string
+              zoneinfo-sample
+            (compose read-zoneinfo list)))
+
+         (timezone-component
+          ;; Seed random to stable UID's.
+          (parameterize (((@ (hnh util uuid) seed) (seed->random-state 0)))
+            (zoneinfo->vtimezone
+             zoneinfo
+             "Europe/Zurich"
+             (vevent summary: "Zoneinfo test"
+                     dtstart: (datetime year: 2020 month: jan day: 10 hour: 10))))))
+
+    (test-assert
+        (vcomponent-equal?
+         (vtimezone tzid: "Europe/Zurich"
+                    (list
+                     (daylight
+                      dtstart: (datetime year: 1981 month: 3 day: 29 hour: 1 tz: "UTC")
+                      rrule: (recur-rule freq: 'YEARLY interval: 1 byday: `((-1 . ,sun)) bymonth: '(3) wkst: monday)
+                      tzname: "CEST"
+                      ;; TODO why isn't this 'hour: 1'?
+                      tzoffsetfrom: (make-timespec (time hour: 0) '+ #\w)
+                      tzoffsetto: (make-timespec (time hour: 2) '+ #\w)
+                      uid: "d19c9347-9a85-4432-a876-5fb9c0d24d2b")
+                     (standard
+                      dtstart: (datetime year: 1996 month: 10 day: 27 hour: 1 tz: "UTC")
+                      rrule: (recur-rule freq: 'YEARLY interval: 1 byday: `((-1 . ,sun)) bymonth: '(10) wkst: monday)
+                      tzname: "CET"
+                      tzoffsetfrom: (make-timespec (time hour: 2) '+ #\w)
+                      tzoffsetto: (make-timespec (time hour: 1) '+ #\w)
+                      uid: "7dce30d4-6aaa-4cfb-85dc-813f74d7f4a9")))
+         timezone-component)))
+
+  ;; TODO these tests
+  ;; (let* () "min max")
+  ;; (let () "min - time")
+  ;; (let "only")
+  )
 
 
 
-- 
cgit v1.2.3