diff options
Diffstat (limited to 'module/output/html.scm')
-rw-r--r-- | module/output/html.scm | 66 |
1 files changed, 45 insertions, 21 deletions
diff --git a/module/output/html.scm b/module/output/html.scm index 167ae78d..a92299d8 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -451,35 +451,58 @@ ;; (stream event-group) -> sxml (define*-public (render-calendar-table key: events start-date end-date pre-start post-end #:allow-other-keys) - (define event-groups (get-groups-between (group-stream events) - pre-start post-end)) + (define-values (long-events short-events) + (partition really-long-event? (stream->list (events-between pre-start post-end events)))) + + (define short-event-groups + (get-groups-between (group-stream (list->stream short-events)) + pre-start post-end)) `((header (@ (class "table-head")) ,(string-titlecase (date->string start-date "~B ~Y"))) (div (@ (class "caltable")) ,@(map (lambda (d) `(div (@ (class "thead")) ,(string-titlecase (week-day-name d)))) (weekday-list (get-config 'week-start))) + ,@(map (lambda (d i) + (define e (date+ d (date day: 6))) + `(div (@ (class "cal-cell cal-cell-long") + (style "grid-area: long " ,i ";" + "grid-column: 1 / span 7;")) + ,@(lay-out-long-events + d e (stream->list + (events-between d e (list->stream long-events)))))) + (date-range pre-start post-end (date day: 7)) + ;; date range limits, 100 ≫ days in month + (iota 100 1)) + ,@(map (lambda (day-date i) + `(div (@ (style "grid-area:time " ,(floor i)) + (class "cal-cell cal-cell-time")) + (time (@ (class "date-info " + ,(if (or (date< day-date start-date) + (date< end-date day-date)) + "non-current" + "current")) + (datetime ,(date->string day-date "~1"))) + (span (@ (class "day-number")) + ,(date->string day-date "~e")) + ,(when (= 1 (day day-date)) + `(span (@ (class "month-name")) + ,(date->string day-date "~b"))) + ,(when (= 1 (month day-date) (day day-date)) + `(span (@ (class "year-number")) + ", " ,(date->string day-date "~Y")))))) + (date-range pre-start post-end) + (iota (length (date-range pre-start post-end)) 1 1/7)) + ,@(stream->list (stream-map - (match-lambda - [(day-date . events) - `(div (@ (class "cal-cell")) - (time (@ (class "date-info " - ,(if (or (date< day-date start-date) - (date< end-date day-date)) - "non-current" - "current")) - (datetime ,(date->string day-date "~1"))) - (span (@ (class "day-number")) - ,(date->string day-date "~e")) - ,(when (= 1 (day day-date)) - `(span (@ (class "month-name")) - ,(date->string day-date "~b"))) - ,(when (= 1 (month day-date) (day day-date)) - `(span (@ (class "year-number")) - ", " ,(date->string day-date "~Y")))) + (match-lambda* + [((day-date . events) i) + `(div (@ (style "grid-area:short " ,(floor (/ i 7))) + (class "cal-cell cal-cell-short")) ,@(stream->list (stream-map make-small-block events)))]) - event-groups))))) + short-event-groups + (stream-from 1)))))) @@ -601,7 +624,8 @@ (error 'html-generate "Prev-start needs to be a procedure")) ;; (display "<!doctype HTML>\n") - ((@ (sxml simple) sxml->xml) + (;;(@ (ice-9 pretty-print) pretty-print) + (@ (sxml simple) sxml->xml) `(*TOP* (*PI* xml "version=\"1.0\" encoding=\"UTF-8\"") ;; "<!doctype html>" |