aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--module/datetime.scm105
-rw-r--r--tests/datetime.scm79
2 files changed, 172 insertions, 12 deletions
diff --git a/module/datetime.scm b/module/datetime.scm
index 50817084..66eab8ca 100644
--- a/module/datetime.scm
+++ b/module/datetime.scm
@@ -15,6 +15,8 @@
:use-module (srfi srfi-41 util)
:use-module (ice-9 i18n)
:use-module (ice-9 format)
+ :use-module (ice-9 match)
+ :use-module (ice-9 regex)
:use-module (calp util config)
:re-export (locale-month locale-month-short)
)
@@ -641,10 +643,48 @@
;;; Input
-(define*-public (string->datetime str optional: (fmt "~Y-~m-~dT~H:~M:~S~Z"))
- (let loop ((str (string->list str))
+#;
+(define (parse-month str)
+ "Get month number from a (shortened) monthname.
+Returns -1 on failure"
+ (let loop ((i 1)
+ (months (map (compose string-locale-downcase locale-month)
+ (iota 12 1))))
+ (if (null? months)
+ -1
+ (let ((len (min (string-length (car months))
+ (string-length str))))
+ (if (string=?
+ (string-take (string-downcase str) len)
+ (string-take (car months) len))
+ i
+ (loop (1+ i) (cdr months)))))))
+
+
+
+(define* (parse-month str optional: (locale %global-locale))
+ "Get month number from a (shortened) monthname.
+Returns -1 on failure"
+ (cond ((find (match-lambda ((_ name)
+ (let ((len (min (string-length name)
+ (string-length str))))
+ (string-locale-ci=? (string-take str len)
+ (string-take name len)
+ locale))))
+ (enumerate (map (lambda (n) (locale-month n locale)) (iota 12 1))))
+ => (compose 1+ car))
+ (else -1)))
+
+
+(define*-public (string->datetime str optional: (fmt "~Y-~m-~dT~H:~M:~S~Z")
+ (locale %global-locale))
+ (let loop* ((str (string->list str))
(fmt (string->list fmt))
- (dt (datetime)))
+ (dt (datetime))
+ (ampm identity))
+
+ (define* (loop str fmt dt optional: (ampm ampm))
+ (loop* str fmt dt ampm))
(define time (get-time% dt))
(define date (get-date dt))
@@ -657,11 +697,11 @@
;; ((@ (calp util exceptions) warning)
;; "Premature end of string, still got fmt = ~s"
;; fmt)
- dt]
+ (ampm dt)]
[(null? fmt)
;; ((@ (calp util exceptions) warning)
;; "Unsparsed characters at end of string")
- dt]
+ (ampm dt)]
[(eq? #\~ (car fmt))
(case (cadr fmt)
[(#\~) (if (eq? #\~ (car str))
@@ -675,6 +715,7 @@
"Mismatched symbol, expected ~a got ~a"
(list #\~ (car str))
#f))]
+ ;; TODO is this lost if not at the end?
[(#\Z)
(if (eq? #\Z (car str))
(loop (cdr str)
@@ -683,8 +724,52 @@
(loop str
(cdr fmt)
dt))]
+ ;; AM/PM
+ [(#\p)
+ (cond ((string-match "^([AaPp])[.]?[Mm][.]?" (list->string str))
+ => (lambda (m)
+ (loop (drop str (match:end m))
+ (cddr fmt)
+ dt
+ (case (string-ref (match:substring m 1) 0)
+ ((#\a #\A)
+ (lambda (dt)
+ (datetime date: (get-date dt)
+ time: (if (= 12 (hour (get-time% dt)))
+ (set (hour (get-time% dt)) 0)
+ (get-time% dt)))))
+ ((#\p #\P)
+ (lambda (dt)
+ (datetime date: (get-date dt)
+ time: (if (= 12 (hour (get-time% dt)))
+ (get-time% dt)
+ (set (hour (get-time% dt))
+ (+ 12 (hour (get-time% dt))))))))))
+ ))
+ ;; fail here?
+ (else (loop str (cddr fmt) dt)))
+ ]
+ ;; month by name
+ [(#\b #\B #\h)
+ (let* ((head post (cond ((null? (cddr fmt)) (values str '()))
+ ((eqv? #\~ (caddr fmt))
+ (cond ((null? (cdddr fmt))
+ (error "Unexpected ~ at end of fmt"))
+ ((eqv? #\~ (cadddr fmt))
+ (span (lambda (c) (not (eqv? #\~ c)))
+ str))
+ (else (error "Can't have format specifier directly after month by name"))))
+ (else (span (lambda (c) (not (eqv? c (caddr fmt))))
+ str)))))
+ (loop post
+ (cddr fmt)
+ (as-dt (set (month date)
+ (parse-month (list->string head) locale)))))]
[(#\H #\M #\S #\m #\d)
- (let* ((pre post (split-at str 2))
+ ;; This captures both the possibility of a date with a single digit,
+ ;; e.g. 7 may, but also compact, digits only, form without delimiters,
+ ;; e.g. --0507,
+ (let* ((pre post (span-upto 2 char-numeric? str))
(num (-> pre list->string string->number)))
(loop
post
@@ -720,11 +805,11 @@
(list (car fmt) (car str))
#f))])))
-(define*-public (string->time str optional: (fmt "~H:~M:~S"))
- (get-time% (string->datetime str fmt)))
+(define*-public (string->time str optional: (fmt "~H:~M:~S") (locale %global-locale))
+ (get-time% (string->datetime str fmt locale)))
-(define*-public (string->date str optional: (fmt "~Y-~m-~d"))
- (get-date (string->datetime str fmt)))
+(define*-public (string->date str optional: (fmt "~Y-~m-~d") (locale %global-locale))
+ (get-date (string->datetime str fmt locale)))
;; Parse @var{string} as either a date, time, or date-time.
;; String MUST be on iso-8601 format.
diff --git a/tests/datetime.scm b/tests/datetime.scm
index 1eb3fb3b..f9cf94e1 100644
--- a/tests/datetime.scm
+++ b/tests/datetime.scm
@@ -1,5 +1,5 @@
;;; Commentary:
-;; Tests date, time, and datetime creation,
+;; Tests date, time, and datetime creation,
;; (output) formatting, and arithmetic.
;;; Code:
@@ -13,9 +13,12 @@
datetime-difference
datetime-
leap-year?
+ string->date string->time string->datetime
)
((ice-9 format) format)
((calp util) let*)
+ ((ice-9 i18n) make-locale)
+ ((guile) LC_TIME)
)
(test-equal "empty time"
@@ -149,5 +152,77 @@
#2020-02-29 (date+ #2020-02-28 (date day: 1)))
+(test-equal "Parse ISO"
+ #2021-12-30T13:53:33
+ (string->datetime "2021-12-30T13:53:33" "~Y-~m-~dT~H:~M:~S"))
-;; TODO string->date family
+(test-equal "Parse ical date-time"
+ #2021-12-30T13:53:33
+ (string->datetime "20211230T135333" "~Y~m~dT~H~M~S"))
+
+
+(test-equal "Parse single hour (padded)"
+ (time hour: 5)
+ (string->time "05" "~H"))
+
+(test-equal "Parse single hour (non-padded)"
+ (time hour: 5)
+ (string->time "5" "~H"))
+
+(test-equal "Parse month (swedish)"
+ (date month: 5)
+ (string->date "Maj" "~b" (make-locale LC_TIME "sv_SE.UTF-8")))
+
+(test-equal "Parse month (english)"
+ (date month: 5)
+ (string->date "May" "~b" (make-locale LC_TIME "en_US.UTF-8")))
+
+(test-equal "AM/PM AM"
+ (time hour: 10)
+ (string->time "10 AM" "~H ~p"))
+
+(test-equal "AM/PM PM"
+ (time hour: 22)
+ (string->time "10 PM" "~H ~p"))
+
+(test-equal "AM/PM AM 12"
+ (time hour: 0)
+ (string->time "12 AM" "~H ~p"))
+
+(test-equal "AM/PM PM 12"
+ (time hour: 12)
+ (string->time "12 PM" "~H ~p"))
+
+(test-equal "AM/PM PM (prefix)"
+ (time hour: 22)
+ (string->time "PM 10" "~p ~H"))
+
+(test-equal "Parse complicated 1"
+ #2021-12-30T10:56:00
+ (string->datetime "Dec. 30, 2021, 10:56"
+ "~b. ~d, ~Y, ~H:~M"
+ (make-locale LC_TIME "en_US.UTF-8")))
+
+(test-equal "Parse complicated 2"
+ #2021-12-30T10:56:00
+ (string->datetime "Dec. 30, 2021, 10:56 a.m."
+ "~b. ~d, ~Y, ~H:~M"
+ (make-locale LC_TIME "en_US.UTF-8")))
+
+(test-equal "Parse complicated 3"
+ #2021-12-30T22:56:00
+ (string->datetime "Dec. 30, 2021, 10:56 p.m."
+ "~b. ~d, ~Y, ~H:~M ~p"
+ (make-locale LC_TIME "en_US.UTF-8")))
+
+(test-equal "Parse date single digit day"
+ (date day: 6)
+ (string->date "6" "~d"))
+
+(test-equal "Parse date single digit day, trailing comma"
+ (date day: 6)
+ (string->date "6," "~d,"))
+
+(test-equal "Parse date single digit day, trailing comma + space"
+ (date day: 6)
+ (string->date "6, " "~d, "))
generated by cgit v1.2.3 (git 2.25.1) at 2024-06-27 23:10:20 +0200