From ae47899079a448b2d71101d4b21c8e9409d82e34 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 23 Mar 2020 00:34:28 +0100 Subject: Remove deprecated get-time. --- module/datetime.scm | 25 +++++++++------- module/datetime/util.scm | 39 ++++++++++++++++++++++-- module/output/html.scm | 14 ++++----- module/output/ical.scm | 49 ++++++++++++++++--------------- module/output/terminal.scm | 18 ++++-------- module/vcomponent/recurrence/generate.scm | 39 +++++++++++------------- module/vcomponent/recurrence/internal.scm | 2 +- tests/datetime-util.scm | 9 +----- 8 files changed, 106 insertions(+), 89 deletions(-) diff --git a/module/datetime.scm b/module/datetime.scm index 2b330a9c..9b0ccd47 100644 --- a/module/datetime.scm +++ b/module/datetime.scm @@ -142,8 +142,8 @@ ;; timezone info it's discarded and a local timestamp produced. ;; It's deprecated since the local time of a datetime can be in another date ;; than the original. which is fun... -(define-public (get-time dt) - (get-time% (get-datetime dt))) +;; (define-public (get-time dt) +;; (get-time% (get-datetime dt))) ;;; UTIL @@ -176,7 +176,7 @@ [else "Object not a date, time, or datetime object ~a" date/-time])) (define-public (as-time date/-time) - (cond [(datetime? date/-time) (get-time date/-time)] + (cond [(datetime? date/-time) (get-time% (get-datetime date/-time))] [(date? date/-time) (time)] [(time? date/-time) date/-time] [else "Object not a date, time, or datetime object ~a" date/-time])) @@ -207,8 +207,10 @@ (= (second a) (second b)))) (define-public (datetime= a b) - (and (date= (get-date a) (get-date b)) - (time= (get-time a) (get-time b)))) + (let ((a (get-datetime a)) + (b (get-datetime b))) + (and (date= (get-date a) (get-date b)) + (time= (get-time% a) (get-time% b))))) (define-many define-public (date=?) date= @@ -530,12 +532,15 @@ ;;; DATETIME +;; NOTE that base is re-normalized, but change isn't. This is due to base +;; hopefully being a real date, but change just being a difference. (define-public (datetime+ base change) - (let* ((time overflow (time+ (get-time base) (get-time change)))) - (datetime date: (date+ (get-date base) - (get-date change) - (date day: overflow)) - time: time))) + (let ((base (get-datetime base))) + (let* ((time overflow (time+ (get-time% base) (get-time% change)))) + (datetime date: (date+ (get-date base) + (get-date change) + (date day: overflow)) + time: time)))) ;; (define (datetime->srfi-19-date date) ;; ((@ (srfi srfi-19) make-date) diff --git a/module/datetime/util.scm b/module/datetime/util.scm index ff75e86d..d5558aa2 100644 --- a/module/datetime/util.scm +++ b/module/datetime/util.scm @@ -150,7 +150,29 @@ #f (string->list fmt))))) -(define*-public (time->string time optional: (fmt "~H:~M:~S") key: allow-unknown?) +;; (define*-public (time->string time optional: (fmt "~H:~M:~S") key: allow-unknown?) +;; (with-output-to-string +;; (lambda () +;; (fold (lambda (token state) +;; (case state +;; ((#\~) +;; (case token +;; ((#\~) (display "~")) +;; ((#\H) (format #t "~2'0d" (hour time))) +;; ((#\M) (format #t "~2'0d" (minute time))) +;; ((#\S) (format #t "~2'0d" (second time))) +;; ;; ((#\z) (when (utc? time) (display "Z"))) +;; (else (unless allow-unknown? +;; (error 'time->string "Invalid format token ~a" token)))) +;; #f) +;; (else (unless (char=? #\~ token) (display token)) token))) +;; #f +;; (string->list fmt))))) + +(define*-public (datetime->string datetime optional: (fmt "~Y-~m-~dT~H:~M:~S") key: allow-unknown?) + (define dt (get-datetime datetime)) + (define date (get-date dt)) + (define time ((@ (datetime) get-time%) dt)) (with-output-to-string (lambda () (fold (lambda (token state) @@ -161,9 +183,21 @@ ((#\H) (format #t "~2'0d" (hour time))) ((#\M) (format #t "~2'0d" (minute time))) ((#\S) (format #t "~2'0d" (second time))) + ;; TODO ;; ((#\z) (when (utc? time) (display "Z"))) + ((#\Y) (format #t "~4'0d" (year date))) + ((#\m) (format #t "~2'0d" (month date))) + ((#\d) (format #t "~2'0d" (day date))) + ;; Should be same as ~_d + ((#\e) (format #t "~2' d" (day date))) + ((#\1) (format #t "~4'0d-~2'0d-~2'0d" + (year date) (month date) (day date))) + ((#\a) (display (week-day-name (week-day date)))) + ;; abriviated locale month name + ;; TODO locale + ((#\b) (display (month-name (month date)))) (else (unless allow-unknown? - (error 'time->string "Invalid format token ~a" token)))) + (error 'datetime->string "Invalid format token ~a" token)))) #f) (else (unless (char=? #\~ token) (display token)) token))) #f @@ -171,7 +205,6 @@ - ;; @verbatim ;; A B C D E ¬F ;; |s1| : |s2| : |s1| : |s2| : : |s1| diff --git a/module/output/html.scm b/module/output/html.scm index 1f4b8e2f..d6a9e8fa 100644 --- a/module/output/html.scm +++ b/module/output/html.scm @@ -28,9 +28,7 @@ ;; TODO currently not guaranteed to be unique (define (UID ev) (string-append - ;; (date/-time->string (attr ev 'DTSTART) "~s") - (date->string (as-date (attr ev 'DTSTART)) "~Y~m~d") - (time->string (as-time (attr ev 'DTSTART)) "~H~M~S") + (datetime->string (as-datetime (attr ev 'DTSTART)) "~Y~m~d~H~M~S") (html-attr (attr ev 'UID)))) ;; This should only be used on time intervals, never on absolute times. @@ -61,12 +59,10 @@ [else ; guaranteed datetime (let ((s (attr ev 'DTSTART)) (e (attr ev 'DTEND))) - (let ((s-str (time->string (get-time s) "~H:~M")) - (e-str (time->string (get-time e) "~H:~M"))) - (if (date= (get-date s) (get-date e)) - (values s-str e-str) - (values (string-append (date->string (get-date s) "~Y-~m-~d ") s-str) - (string-append (date->string (get-date e) "~Y-~m-~d ") e-str)))))])) + (let ((fmt-str (if (date= (get-date s) (get-date e)) + "~H:~M" "~Y-~m-~d ~H:~M"))) + (values (datetime->string s fmt-str) + (datetime->string e fmt-str))))])) diff --git a/module/output/ical.scm b/module/output/ical.scm index c18a203a..0252320b 100644 --- a/module/output/ical.scm +++ b/module/output/ical.scm @@ -16,30 +16,31 @@ (define (value-format key vline) (with-throw-handler 'wrong-type-arg (lambda () - (case key - ((DTSTART DTEND RECURRENCE-ID) - (with-output-to-string - (lambda () - (display (date->string (as-date (value vline)) - "~Y~m~d")) - (when (eq? 'DATE-TIME (and=> (prop vline 'VALUE) car)) - (display (time->string (get-time (value vline)) - "T~H~M~S")) - (let ((tz (and=> (prop vline 'TZID) car))) - (when (and tz (string= tz "UTC")) - (display #\Z)))))) - ) - ((DURATION X-HNH-DURATION) - #; (time->string value "~H~M~S") - (let ((s (second (value vline)))) - (format #f "~a~a~a" - (floor/ s 3600) - (floor/ (modulo s 3600) 60) - (modulo s 60)) - )) - ((RRULE) (value vline)) - - (else (escape-chars (value vline))))) + (case key + ((DTSTART DTEND RECURRENCE-ID) + (with-output-to-string + (lambda () + (case (and=> (prop vline 'VALUE) car) + [(DATE) (display (date->string (as-date (value vline)) + "~Y~m~d"))] + [(DATE-TIME) + (display (datetime->string (value vline) "~Y~m~dT~H~M~S")) + (let ((tz (and=> (prop vline 'TZID) car))) + (when (and tz (string= tz "UTC")) + (display #\Z)))] + [else + (error "Unknown VALUE type")])))) + ((DURATION X-HNH-DURATION) + #; (time->string value "~H~M~S") + (let ((s (second (value vline)))) + (format #f "~a~a~a" + (floor/ s 3600) + (floor/ (modulo s 3600) 60) + (modulo s 60)) + )) + ((RRULE) (value vline)) + + (else (escape-chars (value vline))))) (lambda (err caller fmt args call-args) (format (current-error-port) "WARNING: key = ~a, caller = ~s, call-args = ~s~%~k~%" key caller call-args fmt args) diff --git a/module/output/terminal.scm b/module/output/terminal.scm index 68e66eb9..cb18649d 100644 --- a/module/output/terminal.scm +++ b/module/output/terminal.scm @@ -41,12 +41,10 @@ (display (string-append (if (datetime? (attr ev 'DTSTART)) - (string-append (date->string (get-date (attr ev 'DTSTART))) - " " - (time->string (get-time (attr ev 'DTSTART)))) - ((@ (texinfo string-utils) center-string) - (date->string (attr ev 'DTSTART)) - 19)) + (datetime->string (attr ev 'DTSTART) "~Y-~m-~d ~H:~M:~S") + ((@ (texinfo string-utils) center-string) + (date->string (attr ev 'DTSTART)) + 19)) ; TODO show truncated string " │ " (if (= i cur-event) "\x1b[7m" "") @@ -115,15 +113,11 @@ ;; another story. (let ((start (attr ev 'DTSTART))) (if (datetime? start) - (string-append (date->string (get-date start)) - " " - (time->string (get-time start))) + (datetime->string (attr ev 'DTSTART) "~Y-~m-~d ~H:~M:~S") (date->string start))) (let ((end (attr ev 'DTEND))) (if (datetime? end) - (string-append (date->string (get-date end)) - " " - (time->string (get-time end))) + (datetime->string (attr ev 'DTSTART) "~Y-~m-~d ~H:~M:~S") (date->string end))) (unlines (take-to (flow-text (or (attr ev 'DESCRIPTION) "") #:width (min 70 width)) diff --git a/module/vcomponent/recurrence/generate.scm b/module/vcomponent/recurrence/generate.scm index ac1402fa..ac8a6ad8 100644 --- a/module/vcomponent/recurrence/generate.scm +++ b/module/vcomponent/recurrence/generate.scm @@ -50,30 +50,25 @@ (let ((d (attr e 'DTSTART)) (i (interval r))) - (set! (attr e 'DTSTART) - ((if (date? d) - identity - (lambda (date) - (datetime - date: date - time: (time+ (get-time d) - (case (freq r) - ((SECONDLY) (time second: i)) - ((MINUTELY) (time minute: i)) - ((HOURLY) (time hour: i)) - (else (time))))))) - - (date+ (as-date d) - (case (freq r) - ((DAILY) (date day: i)) - ((WEEKLY) (date day: (* i 7))) - ((MONTHLY) (date month: i)) - ((YEARLY) (date year: i)) - (else (date)))))) + (let ((date-change (case (freq r) + ((DAILY) (date day: i)) + ((WEEKLY) (date day: (* i 7))) + ((MONTHLY) (date month: i)) + ((YEARLY) (date year: i)) + (else (date)))) + (time-change (case (freq r) + ((SECONDLY) (time second: i)) + ((MINUTELY) (time minute: i)) + ((HOURLY) (time hour: i)) + (else (time))))) + (set! (attr e 'DTSTART) + (if (date? d) + (date+ d date-change) + (datetime+ d (datetime date: date-change time: time-change))))) #; - (set! (zone-offset d) - (zone-offset (time-utc->date (date->time-utc d)))) + (set! (zone-offset d) ; + (zone-offset (time-utc->date (date->time-utc d)))) (let ((start (attr e 'DTSTART)) diff --git a/module/vcomponent/recurrence/internal.scm b/module/vcomponent/recurrence/internal.scm index 07fc4cf5..f7b49abc 100644 --- a/module/vcomponent/recurrence/internal.scm +++ b/module/vcomponent/recurrence/internal.scm @@ -38,7 +38,7 @@ (display (case field ;; TODO check over date/time/datetime here - ((until) ((@ (datetime util) time->string) it)) + ;; ((until) ((@ (datetime util) time->string) it)) (else it)) port))) (display ">" port)))))) diff --git a/tests/datetime-util.scm b/tests/datetime-util.scm index ec5da552..4ba432ca 100644 --- a/tests/datetime-util.scm +++ b/tests/datetime-util.scm @@ -1,5 +1,5 @@ (((datetime) date time) - ((datetime util) month-stream in-date-range? time->string) + ((datetime util) month-stream in-date-range?) ((srfi srfi-41) stream->list stream-take )) @@ -24,10 +24,3 @@ (not ((in-date-range? #2020-01-01 #2020-02-29) #2018-02-02))) - -(test-equal "time fmt default" - "10:20:30" (time->string #10:20:30)) - -(test-equal "time fmt custom" - "103020" (time->string #10:20:30 "~H~S~M")) - -- cgit v1.2.3