diff options
| -rw-r--r-- | module/datetime.scm | 98 | ||||
| -rw-r--r-- | module/output/html.scm | 103 | ||||
| -rw-r--r-- | module/vcomponent/datetime.scm | 16 | ||||
| -rw-r--r-- | module/vcomponent/recurrence/generate.scm | 16 | ||||
| -rw-r--r-- | static/style.css | 32 | ||||
| -rw-r--r-- | tests/datetime-compare.scm | 4 |
6 files changed, 183 insertions, 86 deletions
diff --git a/module/datetime.scm b/module/datetime.scm index 3a84e9a2..6c613c55 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -144,8 +144,8 @@ ;; than the original. which is fun... (define-public (get-time dt) (get-time% (get-datetime dt))) - + ;;; UTIL ;; int -> bool @@ -170,14 +170,23 @@ (define-public (as-date date/-time) - (if (date? date/-time) - date/-time - (get-date date/-time))) + (cond [(datetime? date/-time) (get-date date/-time)] + [(date? date/-time) date/-time] + [(time? date/-time) (date)] + [else "Object not a date, time, or datetime object ~a" date/-time])) (define-public (as-time date/-time) - (if (datetime? date/-time) - (get-time date/-time) - (time))) + (cond [(datetime? date/-time) (get-time date/-time)] + [(date? date/-time) (time)] + [(time? date/-time) date/-time] + [else "Object not a date, time, or datetime object ~a" date/-time])) + +(define-public (as-datetime dt) + (cond [(datetime? dt) dt] + [(date? dt) (datetime date: dt time: (time))] + [(time? dt) (datetime time: dt date: (date))] + [else "Object not a date, time, or datetime object ~a" dt])) + ;;; EQUIALENCE @@ -263,15 +272,7 @@ (date<= (get-date a) (get-date b)))) (define-public (date/-time< a b) - ;; (format (current-error-port) "~a < ~a = " a b) - (let ((res - (cond [(date= (as-date a) (as-date b)) - (time< (as-time a) (as-time b))] - [(date< (as-date a) (as-date b)) - #t] - [else #f]))) - ;; (format (current-error-port) "~a~%" res) - res)) + (datetime< (as-datetime a) (as-datetime b))) (define-many define-public (date<?) date< @@ -532,46 +533,45 @@ (date day: overflow)) time: time))) -(define (datetime->srfi-19-date date) - ((@ (srfi srfi-19) make-date) - 0 - (second (get-time date)) - (minute (get-time date)) - (hour (get-time date)) - (day (get-date date)) - (month (get-date date)) - (year (get-date date)) - 0 ; TODO TZ - )) - -(define (srfi-19-date->datetime o) - (let ((y ((@ (srfi srfi-19) date-year) o))) - ;; TODO find better way to translate from 1970 to 0, since this WILL - ;; cause problems sooner or later. - (datetime year: (if (= 1970 y) 0 y) - month: (let ((m ((@ (srfi srfi-19) date-month) o))) - (if (and (= 1970 y) (= 1 m)) 0 m)) - day: (let ((d ((@ (srfi srfi-19) date-day) o))) - (if (and (= 1970 y) (= 1 d)) 0 d)) - hour: ((@ (srfi srfi-19) date-hour) o) - minute: ((@ (srfi srfi-19) date-minute) o) - second: ((@ (srfi srfi-19) date-second) o) - ))) +;; (define (datetime->srfi-19-date date) +;; ((@ (srfi srfi-19) make-date) +;; 0 +;; (second (get-time date)) +;; (minute (get-time date)) +;; (hour (get-time date)) +;; (day (get-date date)) +;; (month (get-date date)) +;; (year (get-date date)) +;; 0 ; TODO TZ +;; )) + +;; (define (srfi-19-date->datetime o) +;; (let ((y ((@ (srfi srfi-19) date-year) o))) +;; ;; TODO find better way to translate from 1970 to 0, since this WILL +;; ;; cause problems sooner or later. +;; (datetime year: (if (= 1970 y) 0 y) +;; month: (let ((m ((@ (srfi srfi-19) date-month) o))) +;; (if (and (= 1970 y) (= 1 m)) 0 m)) +;; day: (let ((d ((@ (srfi srfi-19) date-day) o))) +;; (if (and (= 1970 y) (= 1 d)) 0 d)) +;; hour: ((@ (srfi srfi-19) date-hour) o) +;; minute: ((@ (srfi srfi-19) date-minute) o) +;; second: ((@ (srfi srfi-19) date-second) o) +;; ))) ;;; the *-difference procedures takes two actual datetimes. ;;; date- instead takes a date and a delta (but NOT an actual date). +;; TODO TZ +;; NOTE currently returns the time span in seconds as an int. +;; Who knew that months doesn't have a constant width... (define-public (datetime-difference end start) - (let ((t - ((@ (srfi srfi-19) time-difference) - ((@ (srfi srfi-19) date->time-utc) (datetime->srfi-19-date end)) - ((@ (srfi srfi-19) date->time-utc) (datetime->srfi-19-date start))))) - ((@ (srfi srfi-19) set-time-type!) t (@ (srfi srfi-19) time-utc)) - (srfi-19-date->datetime ((@ (srfi srfi-19) time-utc->date) t 0)))) ; TODO tz offset + (- (car (mktime (datetime->tm end))) + (car (mktime (datetime->tm start))))) (define-public (date-difference end start) - (get-date (datetime-difference (datetime date: end) - (datetime date: start)))) + (datetime-difference (datetime date: end) + (datetime date: start))) ;;; Parsers for vcomponent usage diff --git a/module/output/html.scm b/module/output/html.scm index 9b672a0d..a3e74a44 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -41,6 +41,13 @@ (/ (minute time) 60) (/ (second time) 3600)))) +(define (datetime->decimal-hour datetime) + ;; (+ (time->decimal-hour (get-time datetime)) + ;; (date->decimal-hour (get-date datetime))) + (+ (time->decimal-hour (get-time datetime)) + ;; TODO + (* 3600 24 (day (get-date datetime))))) + ;; Retuns an HTML-safe version of @var{str}. (define (html-attr str) (define cs (char-set-adjoin char-set:letter+digit #\- #\_)) @@ -89,7 +96,7 @@ ;; Takes a list of vcomponents, sets their widths and x-positions to optimally ;; fill out the space, without any overlaps. -(define (fix-event-widths! date lst) +(define* (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 @@ -99,8 +106,8 @@ ;; @var{x} is how for left in the container we are. (let inner ((x 0) (tree (make-tree overlapping? - (sort* lst time>? - (lambda (e) (event-length/day date e)))))) + (sort* lst event-length-comperator event-length-key + )))) (unless (null? tree) (let ((w (/ (- 1 x) (+ 1 (length-of-longst-branch (left-subtree tree)))))) @@ -149,33 +156,66 @@ (define (create-block date ev) (create-block-general date ev "left:~,3f%;width:~,3f%;top:~,3f%;height:~,3f%;")) -(define (create-top-block date ev) - (create-block-general date ev "top:~,3f%;height:~,3f%;left:~,3f%;width:~,3f%;")) +(define (create-top-block start-date end-date ev) + + ;; TODO + (define total-length (exact->inexact (/ (date-difference (date+ end-date (date day: 1)) start-date) 3600))) + + (define style + (format #f "top:~,3f%;height:~,3f%;left:~,3f%;width:~,3f%;" + + ;; Prevent collisions + (* 100 (x-pos ev)) ; top + (* 100 (width ev)) ; height + + ;; Set start time + ;; left + (* 100 + (/ (datetime-difference (as-datetime (attr ev 'DTSTART)) (datetime date: start-date)) + 3600 total-length)) + + ;; Set length of event, which makes end time + ;; width + (* 100 + (/ (event-length/clamped start-date end-date ev) + 3600 total-length)))) + + `(a (@ (href "#" ,(UID ev)) + (class "hidelink")) + (div (@ (class "event CAL_" ,(html-attr (attr (parent ev) 'NAME)) + ,(when (and (attr ev 'PARTSTAT) (string= "TENTATIVE" (attr ev 'PARTSTAT))) + " tentative")) + (style ,style)) + ,((summary-filter) ev (attr ev 'SUMMARY)))) + + ) + ;; Lay out complete day (graphical) ;; (date . (events)) -> sxml (define (lay-out-day day) (let* (((day-date . events) day) (time-obj (datetime date: day-date)) - (long-events short-events + (_ short-events (partition (lambda (ev) (or (date? (attr ev 'DTSTART)) - (datetime<=? (datetime date: (date day: 1)) + (;datetime<=? (datetime date: (date day: 1)) + <= (* 3600 24) (datetime-difference (attr ev 'DTEND) (attr ev 'DTSTART))))) (stream->list events)))) - (fix-event-widths! day-date short-events) - (fix-event-widths! day-date long-events) - `(div (@ (class "day")) + (fix-event-widths! short-events event-length-key: (lambda (e) (event-length/day day-date e))) + ;; (fix-event-widths! day-date long-events) + `(;div (@ (class "day")) (div (@ (class "meta")) ,(let ((str (date-link day-date))) `(span (@ (id ,str) (class "daydate")) ,str)) (span (@ (class "dayname")) ,(date->string day-date "~a"))) - (div (@ (class "wholeday")) - "" ; To prevent self closing div tag - ,@(map (lambda (e) (create-top-block day-date e)) - long-events)) + ;; (div (@ (class "wholeday")) + ;; "" ; To prevent self closing div tag + ;; ,@(map (lambda (e) (create-top-block day-date e)) + ;; long-events)) (div (@ (class "events")) "" ; To prevent self closing div tag ,@(map (lambda (time) @@ -183,6 +223,33 @@ (iota 12 0 2)) ,@(map (lambda (e) (create-block day-date e)) short-events))))) +(define (lay-out-long-events event-groups) + + (define start (car (stream-car event-groups))) + (define end (car (stream-car (stream-reverse event-groups)))) + + (stream-map + (match-lambda + [(d . events) + (let* ((long-events _ + (partition (lambda (ev) + (or (date? (attr ev 'DTSTART)) + (; datetime<=? (datetime date: (date day: 1)) + <= (* 3600 24) + (datetime-difference (attr ev 'DTEND) + (attr ev 'DTSTART))))) + (stream->list events)))) + (let ((long-events + (filter (lambda (e) (date= d (as-date (attr e 'DTSTART)))) + long-events))) + (fix-event-widths! long-events event-length-key: event-length + event-length-comperator: >) + (map (lambda (e) (create-top-block start end e)) + long-events) + + ))]) + event-groups)) + (define (time-marker-div) `(div (@ (class "sideclock")) (div (@ (class "day")) @@ -197,9 +264,13 @@ (define-public (render-calendar event-groups) `(div (@ (class "calendar")) - ,(time-marker-div) + ;; ,(time-marker-div) (div (@ (class "days")) - ,@(stream->list (stream-map lay-out-day event-groups))))) + (div (@ (class "longevents") + (style "grid-column-end:" ,(1+ (stream-length event-groups)))) + "" ; prevent self-closing + ,@(stream->list (lay-out-long-events event-groups))) + ,@(concatenate (stream->list (stream-map lay-out-day event-groups)))))) ;;; Prodcedures for text output diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index 27153cea..ffde1e6e 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -46,9 +46,19 @@ Event must have the DTSTART and DTEND attribute set." ;; Returns length of the event @var{e}, as a time-duration object. (define-public (event-length e) - (time- - (attr e 'DTEND) - (attr e 'DTSTART))) + (if (not (attr e 'DTEND)) + (datetime date: + (if (date? (attr e 'DTSTART)) + #24:00:00 + #01:00:00)) + (let ((ret (datetime-difference (as-datetime (attr e 'DTEND)) + (as-datetime (attr e 'DTSTART))))) + (format (current-error-port) "ret = ~a~%" ret) + ret))) + +(define-public (event-length/clamped start-date end-date e) + (datetime-difference (datetime-min (datetime date: end-date) (as-datetime (attr e 'DTEND))) + (datetime-max (datetime date: start-date) (as-datetime (attr e 'DTSTART))))) ;; Returns the length of the part of @var{e} which is within the day ;; starting at the time @var{start-of-day}. diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index f786a586..ba6257f8 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -81,11 +81,7 @@ (change (attr e 'X-HNH-DURATION))) (when end (set! (attr e 'DTEND) - ((cond - [(date? end) date+ ] - [(datetime? end) datetime+] - [else (error "End neither date nor datetime ~a" end)]) - start change)))))) + (datetime+ (as-datetime start) (datetime time: change))))))) e)) @@ -159,8 +155,9 @@ ;; The value type of dtstart and dtend must be the same ;; according to RFC 5545 3.8.2.2 (Date-Time End). (if (date? end) - (date-difference end (attr event 'DTSTART)) - (datetime-difference end (attr event 'DTSTART))))])) + (time second: (print-and-return (date-difference end (attr event 'DTSTART)))) + (time second: (print-and-return (datetime-difference end (attr event 'DTSTART))))))])) + (format (current-error-port) "duration = ~a~%" (attr event 'X-HNH-DURATION)) (if (attr event "RRULE") (recur-event-stream event (parse-recurrence-rule (attr event "RRULE") @@ -171,8 +168,9 @@ stream-null)))) (lambda (err . args) (format (current-error-port) - "\x1b[0;31mError\x1b[m while parsing recurrence rule (ignoring and continuing)~%~a ~a~%~a~%~%" + "\x1b[0;31mError\x1b[m while parsing recurrence rule (ignoring and continuing)~%~a ~s~%~a~%~%" err args (attr event 'X-HNH-FILENAME)) (stream ; event - )))) + ) + ))) diff --git a/static/style.css b/static/style.css index bfb1f961..99c04921 100644 --- a/static/style.css +++ b/static/style.css @@ -199,10 +199,22 @@ body { .days .meta { border-bottom: 2px solid gray; + grid-row: 1; +} + +.days .events { + grid-row: 3; +} + +.days .longevents { + grid-row: 2; + grid-column-start: 1; + position: relative; } .days { - display: flex; + display: grid; + grid-template-rows: 4em 4em auto; width: 100%; height: 100%; padding: 0; @@ -215,6 +227,8 @@ body { width: 100%; /* height: calc(100% - 50px); */ flex-grow: 1; + /* since day container no longer exists */ + border: 1px solid gray; } /* Clockbar is also .events */ @@ -224,13 +238,13 @@ body { width: 2.5em; } -.wholeday { - position: relative; - width: 100%; - height: calc(3 * 1.5em); - padding-bottom: 2px; - border-bottom: 2px solid black; -} +/* .wholeday { */ +/* position: relative; */ +/* width: 100%; */ +/* height: calc(3 * 1.5em); */ +/* padding-bottom: 2px; */ +/* border-bottom: 2px solid black; */ +/* } */ .wholeday .event { /* max-height: 1.5em; */ @@ -283,7 +297,7 @@ body { } .meta { - height: 50px; + /* height: 50px; */ width: 100%; display: flex; justify-content: center; diff --git a/tests/datetime-compare.scm b/tests/datetime-compare.scm index 0548ac25..eab2b949 100644 --- a/tests/datetime-compare.scm +++ b/tests/datetime-compare.scm @@ -64,4 +64,8 @@ (test-assert "date/-time< other dt, same date" (date/-time< #2020-01-01 #2020-01-01T10:00:00)) +(test-assert "date/-time< time-only" + (date/-time< #00:00:00 #10:00:00)) + (test-assert (not (date/-time< #2018-11-30T08:10:00 #2014-04-13T16:00:00))) + |