From edaf758b80fed1f5f14cd4b192e661c8863e84bc Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 23 Aug 2020 23:22:10 +0200 Subject: Move html modules under calp. --- module/html/view/calendar/month.scm | 117 --------------------------------- module/html/view/calendar/shared.scm | 96 --------------------------- module/html/view/calendar/week.scm | 121 ----------------------------------- 3 files changed, 334 deletions(-) delete mode 100644 module/html/view/calendar/month.scm delete mode 100644 module/html/view/calendar/shared.scm delete 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 deleted file mode 100644 index 99640a22..00000000 --- a/module/html/view/calendar/month.scm +++ /dev/null @@ -1,117 +0,0 @@ -(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 (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)))) - - `((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)) - ((@ (html vcomponent) popup) event - (string-append "popup" ((@ (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/html/view/calendar/shared.scm b/module/html/view/calendar/shared.scm deleted file mode 100644 index d1f58460..00000000 --- a/module/html/view/calendar/shared.scm +++ /dev/null @@ -1,96 +0,0 @@ -(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 deleted file mode 100644 index 34e8eeb4..00000000 --- a/module/html/view/calendar/week.scm +++ /dev/null @@ -1,121 +0,0 @@ -(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))) - `((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)) - ((@ (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