Move html modules under calp.

3 files changed, 334 insertions, 0 deletions

diff --git a/module/calp/html/view/calendar/month.scm b/module/calp/html/view/calendar/month.scm
new file mode 100644
index 00000000..ce8957da
--- /dev/null
+++ b/module/calp/html/view/calendar/month.scm
@@ -0,0 +1,117 @@
+(define-module (calp html view calendar month)
+  :use-module (util)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-41)
+  :use-module (srfi srfi-41 util)
+  :use-module (datetime)
+  :use-module (calp html view calendar shared)
+  :use-module (calp html config)
+  :use-module (vcomponent)
+  :use-module ((vcomponent datetime)
+               :select (really-long-event?
+                        events-between))
+  :use-module ((calp html vcomponent)
+               :select (make-block))
+  :use-module ((vcomponent group)
+               :select (group-stream get-groups-between))
+  )
+
+;; (stream event-group) -> sxml
+(define*-public (render-calendar-table key: events start-date end-date pre-start post-end #:allow-other-keys)
+
+  (define-values (long-events short-events)
+    ;; TODO should be really-long-event? or event-spanning-midnight
+    (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))
+
+  (define long-event-groups
+    (map (lambda (s)
+           (define e (date+ s (date day: 6)))
+           (cons* s e
+                  (stream->list
+                   (events-between s e (list->stream long-events)))))
+         (date-range pre-start post-end (date day: 7))))
+
+  `((script "const VIEW='month';")
+    (header (@ (class "table-head"))
+            ,(string-titlecase (date->string start-date "~B ~Y")))
+    (div (@ (class "caltable")
+            (style "grid-template-rows: 2em"
+              ,(string-concatenate
+                (map (lambda (long-group)
+                       (format #f " [time] 15pt [long] ~amm [short] 1fr"
+                               (min 10 (* 4 (length (cddr long-group))))))
+                     long-event-groups))))
+         ,@(map (lambda (d) `(div (@ (class "thead")) ,(string-titlecase (week-day-name d))))
+                (weekday-list))
+         ,@(map (lambda (group i)
+                  (let* (((s e . events) group))
+                    `(div (@ (class "cal-cell longevents event-container")
+                             (style "grid-area: long " ,i ";"
+                                    "grid-column: 1 / span 7;")
+                             (data-start ,(date->string s))
+                             (data-end ,(date->string (add-day e))))
+                          ,@(lay-out-long-events
+                             s e events))))
+                long-event-groups
+                (iota (length long-event-groups) 1))
+
+         ,@(caltable-time-cells start-date end-date
+                                pre-start post-end)
+
+         ,@(stream->list
+            (stream-map
+             (lambda (group i)
+               (define day-date (car group))
+               (define events (cdr group))
+               `(div (@ (style "grid-area:short " ,i)
+                        (class "cal-cell cal-cell-short event-container")
+                        (data-start ,(date->string day-date))
+                        (data-end ,(date->string (add-day day-date))))
+                     (div (@ (style "overflow-y:auto;"))
+                      ,@(map make-small-block (stream->list events)))))
+             short-event-groups
+             (repeating-naturals 1 7)
+             )))
+
+    ;; These popups are relative the document root. Can thus be placed anywhere in the DOM.
+    ,@(for event in (stream->list
+                     (events-between start-date end-date events))
+           ((@ (calp html vcomponent) popup) event
+            (string-append "popup" ((@ (calp html util) html-id) event))))
+    ))
+
+
+
+;;; Table output
+
+(define (make-small-block event)
+  (make-block event))
+
+(define (caltable-time-cells start-date end-date
+                             pre-start post-end)
+  (map (lambda (day-date i)
+         `(div (@ (style "grid-area:time " ,i)
+                  (class "cal-cell cal-cell-time"))
+               (a (@ (class "hidelink")
+                     (href "/week/" ,(date->string day-date "~Y-~m-~d")
+                           ".html#" ,(date->string day-date "~Y-~m-~d")))
+                (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)
+       (map floor (iota (length (date-range pre-start post-end)) 1 1/7))))
diff --git a/module/calp/html/view/calendar/shared.scm b/module/calp/html/view/calendar/shared.scm
new file mode 100644
index 00000000..73698060
--- /dev/null
+++ b/module/calp/html/view/calendar/shared.scm
@@ -0,0 +1,96 @@
+(define-module (calp html view calendar shared)
+  :use-module (util)
+  :use-module (srfi srfi-1)
+  :use-module (vcomponent)
+  :use-module ((vcomponent datetime)
+               :select (event-length
+                        overlapping?
+                        event-length/clamped))
+  :use-module ((vcomponent datetime output)
+               :select (format-summary))
+  :use-module (util tree)
+  :use-module (datetime)
+  :use-module (calp html config)
+  :use-module ((calp html components)
+               :select (btn tabset))
+  :use-module ((calp html vcomponent)
+               :select (make-block) )
+  )
+
+
+
+(define-public x-pos (make-object-property))
+(define-public width (make-object-property))
+
+
+;; Takes a list of vcomponents, sets their widths and x-positions to optimally
+;; fill out the space, without any overlaps.
+(define*-public (fix-event-widths! lst key: event-length-key (event-length-comperator date/-time>?))
+  ;; The tree construction is greedy. This means
+  ;; that if  a smaller  event preceeds a longer
+  ;; event it would capture  the longer event to
+  ;; only find  events which  also overlaps  the
+  ;; smaller event.
+
+  ;; @var{x} is how for left in the container we are.
+  (let inner ((x 0)
+              (tree (make-tree overlapping?
+                               (sort* lst event-length-comperator event-length-key
+                                      ))))
+    (unless (null? tree)
+      (let ((w (/ (- 1 x)
+                  (+ 1 (length-of-longst-branch (left-subtree tree))))))
+        (set! (width (car tree)) w
+              (x-pos (car tree)) x)
+        (inner (+ x w) (left-subtree tree))
+        (inner x (right-subtree tree))))))
+
+
+(define-public (lay-out-long-events start end events)
+  (fix-event-widths! events event-length-key: event-length
+                     event-length-comperator: date/-time>)
+  (map (lambda (e) (create-top-block start end e))
+       events))
+
+;; date{,time}-difference works in days, and days are simply multiplied by 24 to
+;; get hours.  This means that a day is always assumed to be 24h, even when that's
+;; wrong. This might lead to some weirdness when the timezon switches (DST), but it
+;; makes everything else behave MUCH better.
+(define-public (create-top-block start-date end-date ev)
+
+  (define total-length
+    (* 24 (days-in-interval start-date end-date)))
+
+  (define top (* 100 (x-pos ev)))
+  (define height (* 100 (width ev)))
+  (define left ; start time
+    (* 100
+       (let* ((dt (datetime date: start-date))
+              (diff (datetime-difference
+                     (datetime-max dt (as-datetime (prop ev 'DTSTART)))
+                     dt)))
+         (/ (datetime->decimal-hour diff start-date) total-length))))
+
+  ;; Set length of event, which makes end time
+  (define width*
+    (* 100
+       (/ (datetime->decimal-hour
+           (as-datetime (event-length/clamped start-date end-date ev))
+           start-date)
+          total-length)))
+
+  (define style
+    (if (edit-mode)
+        (format #f "top:calc(var(--editmode)*~,3f%);height:calc(var(--editmode)*~,3f%);left:~,3f%;width:~,3f%;"
+                top height left width*)
+        (format #f "top:~,3f%;height:~,3f%;left:~,3f%;width:~,3f%;"
+                top height left width*)))
+
+  (make-block
+   ev `((class
+          ,(when (date/-time< (prop ev 'DTSTART) start-date)
+             " continued")
+          ,(when (and (prop ev 'DTEND)
+                      (date/-time< (date+ end-date (date day: 1)) (prop ev 'DTEND)))
+             " continuing"))
+        (style ,style))))
diff --git a/module/calp/html/view/calendar/week.scm b/module/calp/html/view/calendar/week.scm
new file mode 100644
index 00000000..ca6aa9f8
--- /dev/null
+++ b/module/calp/html/view/calendar/week.scm
@@ -0,0 +1,121 @@
+(define-module (calp html view calendar week)
+  :use-module (util)
+  :use-module (srfi srfi-1)
+  :use-module (srfi srfi-41)
+  :use-module (datetime)
+  :use-module (calp html view calendar shared)
+  :use-module (calp html config)
+  :use-module (calp html util)
+  :use-module (vcomponent)
+  :use-module ((vcomponent datetime)
+               :select (long-event?
+                        event-length/day
+                        event-zero-length?
+                        events-between))
+  :use-module ((calp html vcomponent)
+               :select (make-block) )
+  :use-module ((vcomponent group)
+               :select (group-stream get-groups-between))
+  )
+
+
+(define*-public (render-calendar key: events start-date end-date #:allow-other-keys)
+  (let* ((long-events short-events (partition long-event? (stream->list (events-between start-date end-date events))))
+         (range (date-range start-date end-date)))
+    `((script "const VIEW='week';")
+      (div (@ (class "calendar"))
+           (div (@ (class "days"))
+                ,@(time-marker-div)
+                (div (@ (class "longevents event-container")
+                        (data-start ,(date->string start-date) )
+                        (data-end ,(date->string (add-day end-date)) )
+                        (style "grid-column-end: span " ,(days-in-interval start-date end-date)))
+                     ,@(lay-out-long-events start-date end-date long-events))
+                ,@(map (lambda (day-date)
+                         `(div (@ (class "meta"))
+                               (span (@ (class "daydate"))
+                                     ,(date->string day-date "~Y-~m-~d"))
+                               (span (@ (class "dayname"))
+                                     ,(string-titlecase (date->string day-date "~a")))))
+                       range)
+                ,@(stream->list
+                   (stream-map
+                    lay-out-day
+                    (get-groups-between (group-stream (list->stream short-events))
+                                        start-date end-date)))
+
+                ,@(for event in (stream->list
+                                 (events-between start-date end-date events))
+                       ((@ (calp html vcomponent ) popup) event (string-append "popup" (html-id event))))
+
+                )))))
+
+
+
+(define (time-marker-div)
+  ;; element to make rest of grid align correct.
+  ;; Could be extended to contain something fun.
+  `((div (@ (style "grid-row: 1 / span 2")))
+    (div (@ (class "sideclock"))
+         ,@(map (lambda (time)
+                  `(div (@ (class "clock clock-" ,time))
+                        (span (@ (class "clocktext"))
+                              ,time ":00")))
+                (iota 12 0 2)))))
+
+;; Lay out complete day (graphical)
+;; (date . (events)) -> sxml
+(define (lay-out-day day)
+  (let* (((day-date . events) day)
+         (time-obj (datetime date: day-date))
+         (zero-length-events short-events
+                             (partition event-zero-length? (stream->list events))))
+
+    (fix-event-widths! short-events event-length-key:
+                       (lambda (e) (event-length/day day-date e)))
+
+    `(div (@ (class "events event-container") (id ,(date-link day-date))
+             (data-start ,(date->string day-date))
+             (data-end ,(date->string (add-day day-date)) ))
+          ,@(map (lambda (time)
+                   `(div (@ (class "clock clock-" ,time))))
+                 (iota 12 0 2))
+          (div (@ (class "zero-width-events"))
+               ,(map make-block zero-length-events))
+          ,@(map (lambda (e) (create-block day-date e)) short-events))))
+
+
+
+;; Format single event for graphical display
+;; This is extremely simmilar to create-top-block, which currently recides in ./shared
+(define (create-block date ev)
+  ;; (define time (date->time-utc day))
+
+  (define left  (* 100 (x-pos ev)))
+  (define width* (* 100 (width ev)))
+  (define top (if (date= date (as-date (prop ev 'DTSTART)))
+                  (* 100/24
+                     (time->decimal-hour
+                      (as-time (prop ev 'DTSTART))))
+                  0))
+  (define height (* 100/24 (time->decimal-hour (event-length/day date ev))))
+
+
+  (define style
+    ;; The calc's here is to enable an "edit-mode".
+    ;; Setting --editmode ≈ 0.8 gives some whitespace to the right
+    ;; of the events, alowing draging there for creating new events.
+    (if (edit-mode)
+        (format #f "left:calc(var(--editmode)*~,3f%);width:calc(var(--editmode)*~,3f%);top:~,3f%;height:~,3f%;"
+
+                left width* top height)
+        (format #f "left:~,3f%;width:~,3f%;top:~,3f%;height:~,3f%;"
+                left width* top height)))
+
+  (make-block
+   ev `((class
+          ,(when (date<? (as-date (prop ev 'DTSTART)) date)
+             " continued")
+          ,(when (and (prop ev 'DTEND) (date<? date (as-date (prop ev 'DTEND))))
+             " continuing"))
+        (style ,style))))