Add ~b and ~p flags to datetime parser.

1 files changed, 95 insertions, 10 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.