From 327b322b9583f760cd02ddad7a2a8890df26cc8b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Thu, 23 Jun 2022 01:39:08 +0200
Subject: work

---
 module/calp/html/view/calendar.scm | 128 +++++++++++++++++++++----------------
 1 file changed, 72 insertions(+), 56 deletions(-)

(limited to 'module/calp/html/view/calendar.scm')

diff --git a/module/calp/html/view/calendar.scm b/module/calp/html/view/calendar.scm
index 8b7d8075..9e2992a4 100644
--- a/module/calp/html/view/calendar.scm
+++ b/module/calp/html/view/calendar.scm
@@ -2,7 +2,7 @@
   :use-module (hnh util)
   :use-module (vcomponent)
   :use-module ((vcomponent datetime)
-               :select (events-between))
+               :select (ev-time<? events-between))
   :use-module (datetime)
   :use-module (calp html components)
   :use-module ((calp html vcomponent)
@@ -10,7 +10,6 @@
                         fmt-day
                         make-block
                         fmt-single-event
-                        output-uid
                                           ))
   :use-module (calp html config)
   :use-module (calp html util)
@@ -29,8 +28,14 @@
                :select (group-stream get-groups-between))
   :use-module ((base64) :select (base64encode))
 
+  :use-module ((vcomponent util instance) :select (global-event-object))
+  :use-module ((vcomponent util instance methods) :select (fixed-events-in-range
+                                                           repeating-events-in-range))
+
   :use-module (ice-9 format)
   :use-module (calp translation)
+  :use-module ((vcomponent formats xcal output)
+               :select (vcomponent->sxcal))
   )
 
 
@@ -46,6 +51,35 @@
 (define repo-url (make-parameter "https://git.hornquist.se/calp"))
 
 
+;; Mapping showing which events belongs to which calendar,
+;; on the form
+;; (calendar (@ (key ,(base64-encode calendar-name)))
+;;           (li ,event-uid) ...)
+(define (calendar-event-mapping events)
+  `(div (@ (style "display:none !important;")
+           (id "calendar-event-mapping"))
+
+        ;; ,(for (calendar entries ...) in (group-by parent events)
+        ;;       `(calendar (@ (key ,(base64encode (prop calendar 'NAME))))
+        ;;                  ,@(map (lambda (uid) `(li ,uid))
+        ;;                         (map (extract 'UID) entries))))
+
+        ,(let ((ht (make-hash-table)))
+           (for-each (lambda (event)
+                       (define name (prop (parent event) 'NAME))
+                       (hash-set! ht name
+                                  (cons (prop event 'UID)
+                                        (hash-ref ht name '()))))
+                     events)
+
+           (hash-map->list
+            (lambda (key values)
+              `(calendar (@ (key ,(base64encode key)))
+                         ,@(map (lambda (uid) `(li ,uid))
+                                values)))
+            ht))))
+
+
 ;; TODO document what @var{render-calendar} is supposed to take and return.
 ;; Can at least note that @var{render-calendar} is strongly encouraged to include
 ;; (script "const VIEW='??';"), where ?? is replaced by the name of the view.
@@ -362,57 +396,39 @@ window.default_calendar='~a';"
                        SEQUENCE REQUEST-STATUS
                        )))
 
-    ,@(let* (
-             (flat-events
-              ;; A simple filter-sorted-stream on event-overlaps? here fails.
-              ;; See tests/annoying-events.scm
-              (stream->list
-               (stream-filter
-                (lambda (ev)
-                  ((@ (vcomponent datetime) event-overlaps?)
-                   ev pre-start
-                   (date+ post-end (date day: 1))))
-                (stream-take-while (lambda (ev) (date<
-                                            (as-date (prop ev 'DTSTART))
-                                            (date+ post-end (date day: 1))))
-                                   events))))
-             (repeating% regular (partition repeating? flat-events))
-             (repeating
-              (for ev in repeating%
-                   (define instance (copy-vcomponent ev))
-
-                   (set! (prop instance 'UID) (output-uid instance))
-                   (delete-parameter! (prop* instance 'DTSTART) '-X-HNH-ORIGINAL)
-                   (delete-parameter! (prop* instance 'DTEND)   '-X-HNH-ORIGINAL)
-
-                   instance)))
-
-        `(
-          ;; Mapping showing which events belongs to which calendar,
-          ;; on the form
-          ;; (calendar (@ (key ,(base64-encode calendar-name)))
-          ;;           (li ,event-uid) ...)
-          (div (@ (style "display:none !important;")
-                  (id "calendar-event-mapping"))
-               ,(let ((ht (make-hash-table)))
-                  (for-each (lambda (event)
-                              (define name (prop (parent event) 'NAME))
-                              (hash-set! ht name
-                                         (cons (prop event 'UID)
-                                               (hash-ref ht name '()))))
-                            (append regular repeating))
-
-                  (hash-map->list
-                   (lambda (key values)
-                     `(calendar (@ (key ,(base64encode key)))
-                                ,@(map (lambda (uid) `(li ,uid))
-                                       values)))
-                   ht)))
-
-          ;; Calendar data for all events in current interval,
-          ;; rendered as xcal.
-          (div (@ (style "display:none !important;")
-                   (id "xcal-data"))
-                ,((@ (vcomponent formats xcal output) ns-wrap)
-                  (map (@ (vcomponent formats xcal output) vcomponent->sxcal)
-                       (append regular repeating)))))))))
+    ,(let ((regular   (fixed-events-in-range     global-event-object start-date end-date))
+           (repeating (repeating-events-in-range global-event-object start-date end-date)))
+
+       `(div (@ (style "display:none !important"))
+             ,(calendar-event-mapping (append regular repeating))
+
+             ;; Calendar data for all events in current interval,
+             ;; rendered as xcal.
+             (div (@ (id "xcal-data"))
+                  ,((@ (vcomponent formats xcal output) ns-wrap)
+                    (map vcomponent->sxcal regular)))
+
+             (div (@ (id "xcal-data-repeating"))
+                  ,((@ (vcomponent formats xcal output) ns-wrap)
+                    (map vcomponent->sxcal
+                         ;; TODO possibly create generate-reccurrence-set-in-interval
+                         (map (lambda (event)
+                                (delete-parameter! (prop* event 'DTSTART) '-X-HNH-ORIGINAL)
+                                (delete-parameter! (prop* event 'DTEND) '-X-HNH-ORIGINAL)
+                                event)
+                          (stream->list
+                           (events-between
+                            start-date end-date
+                            (interleave-streams
+                             ev-time<?
+                             (map generate-recurrence-set repeating)))))))
+
+                  )
+             )
+
+       #;
+       (map (lambda (ev)
+       (set! (prop ev 'X-HNH-INSTANCE-ID)
+       (datetime->string (as-datetime (prop ev 'DTSTART))))
+       (vcomponent->sxcal ev))
+       repeating)))))
-- 
cgit v1.2.3