From e7c99e14691e768e0c3e7c54049301183ddfc32f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Tue, 24 Mar 2020 22:52:57 +0100 Subject: Change date{,time}-difference to hopefully sensible types. --- module/datetime.scm | 76 ++++++++++++++++++++++++++----- module/output/html.scm | 19 ++++---- module/vcomponent/datetime.scm | 16 +++++-- module/vcomponent/recurrence/generate.scm | 4 +- 4 files changed, 89 insertions(+), 26 deletions(-) (limited to 'module') diff --git a/module/datetime.scm b/module/datetime.scm index 1dd2f9bd..4a53ed95 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -581,17 +581,71 @@ ;;; 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) - (- (car (mktime (datetime->tm end))) - (car (mktime (datetime->tm start))))) - -(define-public (date-difference end start) - (date day: (ceiling-quotient (datetime-difference (datetime date: end) - (datetime date: start)) - 86400))) +;; Works on 0-based dates. So the last of January 2020 becomes +;; 2020-00-30 +(define (date-difference% b a) + ;; #2020-01-01 #2020-00-26 → #2020-00-06 #2020-00-00 + (define-values (b* a*) + (let loop ((b b) (a a)) + ;; (format (current-error-port) "a=~a b=~a~%" a b) + (if (> (day a) (day b)) + (let ((new-a (set (day a) = (- (1+ (day b)))))) + (loop (if (= 0 (month b)) + (set-> b + (year = (- 1)) + (month 11) + (day 30) ; Last day in december + ) + (set-> b + (month = (- 1)) + (day (1- (days-in-month (set (month b) = (- 0))))))) + new-a)) + ;; elif (> (day b) (day a)) + (values (set (day b) = (- (day a))) + (set (day a) 0))))) + + (define-values (b** a**) + (let loop ((b b*) (a a*)) + (if (> (month a) (month b)) + (loop (set-> b + (year = (- 1)) + (month 11)) + (set (month a) = (- (month b)))) + ;; elif (> (month b) (month a)) + (values (set (month b) = (- (month a))) + (set (month a) 0))))) + + ;; a** should here should have both month and date = 0 + + (set (year b**) = (- (year a**)))) + + +(define-public (date-difference b a) + (when (or (negative? (month b)) + (negative? (day b)) + (negative? (month a)) + (negative? (day a)) ) + (error "Negative months or days are an error")) + + (date-difference% (set-> b + (month = (- 1)) + (day = (- 1))) + (set-> a + (month = (- 1)) + (day = (- 1))))) + + +(define-public (datetime-difference end* start*) + ;; NOTE Makes both start and end datetimes in the current local time. + (let ((end (get-datetime end*)) + (start (get-datetime start*))) + (let* ((fixed-time overflow (time- (get-time% end) + (get-time% start)))) + (datetime date: (date-difference (date- (get-date end) + (date day: overflow)) + (get-date start)) + time: fixed-time)))) + ;;; Parsers for vcomponent usage diff --git a/module/output/html.scm b/module/output/html.scm index cb0ba9b5..9f5c7c81 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -82,9 +82,9 @@ ;; of a regular day. (define (long-event? ev) (or (date? (attr ev 'DTSTART)) - (<= (* 3600 24) - (datetime-difference (attr ev 'DTEND) - (attr ev 'DTSTART))))) + (datetime<= (datetime date: (date day: 1)) + (datetime-difference (attr ev 'DTEND) + (attr ev 'DTSTART))))) (define (event-debug-html event) @@ -185,15 +185,16 @@ ;; Set start time ;; left (* 100 - (let ((dt (datetime date: start-date))) - (/ (datetime-difference (datetime-max dt (as-datetime (attr ev 'DTSTART))) dt) - 3600 total-length))) + (let* ((dt (datetime date: start-date)) + (diff (datetime-difference (datetime-max dt (as-datetime (attr ev 'DTSTART))) + dt))) + (/ (datetime->decimal-hour diff) total-length))) ;; Set length of event, which makes end time ;; width (* 100 - (/ (event-length/clamped start-date end-date ev) - 3600 total-length)))) + (/ (datetime->decimal-hour (as-datetime (event-length/clamped start-date end-date ev))) + total-length)))) `(a (@ (href "#" ,(UID ev)) (class "hidelink")) @@ -232,7 +233,7 @@ (define (lay-out-long-events start end events) (fix-event-widths! events event-length-key: event-length - event-length-comperator: >) + event-length-comperator: date/-time>) (map (lambda (e) (create-top-block start end e)) events)) diff --git a/module/vcomponent/datetime.scm b/module/vcomponent/datetime.scm index 4db9dbf1..5df4dfab 100644 --- a/module/vcomponent/datetime.scm +++ b/module/vcomponent/datetime.scm @@ -51,12 +51,20 @@ Event must have the DTSTART and DTEND attribute set." (if (date? (attr e 'DTSTART)) #24:00:00 #01:00:00)) - (datetime-difference (as-datetime (attr e 'DTEND)) - (as-datetime (attr e 'DTSTART))))) + ((if (date? (attr e 'DTSTART)) + date-difference datetime-difference) + (attr e 'DTEND) (attr e 'DTSTART)))) (define-public (event-length/clamped start-date end-date e) - (datetime-difference (datetime-min (datetime date: (date+ end-date (date day: 1))) (as-datetime (attr e 'DTEND))) - (datetime-max (datetime date: start-date) (as-datetime (attr e 'DTSTART))))) + (if (date? (attr e 'DTSTART)) + (date-difference (date-min (date+ end-date (date day: 1)) + (attr e 'DTEND)) + (date-max start-date + (attr e 'DTSTART))) + (datetime-difference (datetime-min (datetime date: (date+ end-date (date day: 1))) + (get-datetime (attr e 'DTEND))) + (datetime-max (datetime date: start-date) + (get-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 ac8a6ad8..ce64e741 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -78,7 +78,7 @@ (set! (attr e 'DTEND) (if (date? start) (date+ start change) - (datetime+ start (datetime time: change)))))))) + (datetime+ start change))))))) e)) @@ -153,7 +153,7 @@ ;; according to RFC 5545 3.8.2.2 (Date-Time End). (if (date? end) (date-difference end (attr event 'DTSTART)) - (time second: (datetime-difference end (attr event 'DTSTART)))))])) + (datetime-difference end (attr event 'DTSTART))))])) (if (attr event "RRULE") (recur-event-stream event (parse-recurrence-rule (attr event "RRULE") -- cgit v1.2.3