diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-10 17:23:34 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-10 17:23:34 +0200 |
commit | e028543baa552aa091fe3485b03da48d25ab8179 (patch) | |
tree | 89d481c7509d3634bce76e9319cb192c2b25a328 /module/html/view/calendar/month.scm | |
parent | HTML work. (diff) | |
download | calp-e028543baa552aa091fe3485b03da48d25ab8179.tar.gz calp-e028543baa552aa091fe3485b03da48d25ab8179.tar.xz |
Really start breaking apart HTML.
Diffstat (limited to '')
-rw-r--r-- | module/html/view/calendar/month.scm | 110 |
1 files changed, 110 insertions, 0 deletions
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)))) |