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/week.scm | |
parent | HTML work. (diff) | |
download | calp-e028543baa552aa091fe3485b03da48d25ab8179.tar.gz calp-e028543baa552aa091fe3485b03da48d25ab8179.tar.xz |
Really start breaking apart HTML.
Diffstat (limited to 'module/html/view/calendar/week.scm')
-rw-r--r-- | module/html/view/calendar/week.scm | 114 |
1 files changed, 114 insertions, 0 deletions
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<? (as-date (prop ev 'DTSTART)) date) + " continued") + ,(when (and (prop ev 'DTEND) (date<? date (as-date (prop ev 'DTEND)))) + " continuing")) + (style ,style)))) |