Start work on long event layout for months.

4 files changed, 105 insertions, 26 deletions

diff --git a/module/datetime.scm b/module/datetime.scm
index fdab2fe6..1141aa64 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -554,10 +554,10 @@
 ;; Returns a list of all dates from start to end.
 ;; both inclusive
 ;; date, date → [list date]
-(define-public (date-range start end)
+(define*-public (date-range start end optional: (increment (date day: 1)))
   (stream->list
    (stream-take-while (lambda (d) (date<= d end))
-                      (day-stream start))))
+                      (date-stream increment start))))
 
 
 ;;; Output
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>"
diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm
index 3f81c359..faeae70a 100644
--- a/module/vcomponent/datetime.scm
+++ b/module/vcomponent/datetime.scm
@@ -122,6 +122,15 @@ Event must have the DTSTART and DTEND protperty set."
                        (datetime-difference it (prop ev 'DTSTART)))
            #f)))
 
+(define-public (really-long-event? ev)
+  (let ((start (prop ev 'DTSTART))
+        (end (prop ev 'DTEND)))
+   (if (date? start)
+       (and end (date< (date+ start (date day: 1)) end))
+       (and end
+            (datetime< (datetime date: (date day: 1))
+                       (datetime-difference end start))))))
+
 
 ;; DTEND of the last instance of this event.
 ;; event → (or datetime #f)
@@ -136,7 +145,7 @@ Event must have the DTSTART and DTEND protperty set."
                  (as-datetime final))
             #f))))
 
-;; date, date, [sorted-stream events] → [list events]
+;; date, date, [sorted-stream events] → [sorted-stream events]
 (define-public (events-between start-date end-date events)
   (define (overlaps e)
     (timespan-overlaps? start-date (date+ end-date (date day: 1))
diff --git a/static/style.css b/static/style.css
index 793ed366..f1bdc6fb 100644
--- a/static/style.css
+++ b/static/style.css
@@ -323,8 +323,9 @@ along with their colors.
     /* This is for the first name, the week days.
        NOTE that I'm not sure this is actually the
        correct way to do it. */
-    grid-template-rows: 2em;
-    grid-auto-rows: 1fr;
+    /* grid-template-rows: 2em; */
+    /* grid-auto-rows: 1fr; */
+    grid-template-rows: 2em repeat(6, [time] 15pt [long] 1fr [short] 1fr);
 
     max-height: 100%;
     /* Apparently needed to ensure that parent can contain all its children */
@@ -343,8 +344,48 @@ along with their colors.
     border: 1px solid var(--gray);
 }
 
+.caltable .cal-cell-time {
+    border-bottom: none;
+}
+
+.caltable .cal-cell-short {
+    border-top: none
+}
+
+.caltable .cal-cell-long .event {
+    margin: 0;
+    /* TODO use other border rules */
+    border: 1px solid black;
+}
+
+.caltable .cal-cell-long .continuing {
+    border-radius: 1cm 0 0 1cm;
+}
+
+.caltable .cal-cell-long .continued {
+    border-radius: 0 1cm 1cm 0;
+}
+
+.caltable .cal-cell-long .continuing.continued {
+    border-radius: 0;
+}
+
+.caltable .cal-cell-long {
+    border-bottom: none;
+    border-top: none;
+    position: relative;
+}
+
+.caltable .cal-cell-long .event {
+    position: absolute;
+    box-sizing: border-box;
+    padding: 0;
+}
+
 .caltable .cal-cell {
     overflow-y: auto;
+    /* for long events */
+    overflow-x: hidden;
 }
 
 .cal-cell .event {
@@ -355,11 +396,16 @@ along with their colors.
     font-family: arial;
 }
 
+
 .date-info .day-number {
     font-size: 150%;
     padding: 2pt;
 }
 
+.caltable .day-number {
+    font-size: initial;
+}
+
 .date-info.current .day-number {
     color: black;
 }