From e028543baa552aa091fe3485b03da48d25ab8179 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 10 Aug 2020 17:23:34 +0200 Subject: Really start breaking apart HTML. --- module/html/view/calendar/month.scm | 110 +++++++++++++++++++++++++++++++++ module/html/view/calendar/shared.scm | 96 +++++++++++++++++++++++++++++ module/html/view/calendar/week.scm | 114 +++++++++++++++++++++++++++++++++++ 3 files changed, 320 insertions(+) create mode 100644 module/html/view/calendar/month.scm create mode 100644 module/html/view/calendar/shared.scm create mode 100644 module/html/view/calendar/week.scm (limited to 'module/html/view/calendar') diff --git a/module/html/view/calendar/month.scm b/module/html/view/calendar/month.scm new file mode 100644 index 00000000..f02a10d6 --- /dev/null +++ b/module/html/view/calendar/month.scm @@ -0,0 +1,110 @@ +(define-module (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 (html view calendar shared) + :use-module (html config) + :use-module (util config) + :use-module (vcomponent) + :use-module ((vcomponent datetime) + :select (really-long-event? + events-between)) + :use-module ((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)))) + + `((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 (get-config 'week-start))) + ,@(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) + ))))) + + + +;;; 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/html/view/calendar/shared.scm b/module/html/view/calendar/shared.scm new file mode 100644 index 00000000..d1f58460 --- /dev/null +++ b/module/html/view/calendar/shared.scm @@ -0,0 +1,96 @@ +(define-module (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 (html config) + :use-module ((html components) + :select (btn tabset)) + :use-module ((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/html/view/calendar/week.scm b/module/html/view/calendar/week.scm new file mode 100644 index 00000000..7da186e1 --- /dev/null +++ b/module/html/view/calendar/week.scm @@ -0,0 +1,114 @@ +(define-module (html view calendar week) + :use-module (util) + :use-module (srfi srfi-1) + :use-module (srfi srfi-41) + :use-module (datetime) + :use-module (html view calendar shared) + :use-module (html config) + :use-module (html util) + :use-module (vcomponent) + :use-module ((vcomponent datetime) + :select (long-event? + event-length/day + event-zero-length? + events-between)) + :use-module ((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))) + `((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)))))))) + + + +(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