diff options
Diffstat (limited to 'module/calp/html/view/calendar.scm')
| -rw-r--r-- | module/calp/html/view/calendar.scm | 128 |
1 files changed, 72 insertions, 56 deletions
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))))) |