diff --git a/host/chez/inst-time.ss b/host/chez/inst-time.ss index 6930385..0c6870b 100644 --- a/host/chez/inst-time.ss +++ b/host/chez/inst-time.ss @@ -150,9 +150,83 @@ ((char=? c #\m) (display (if (= k 1) (number->string mi) (pad2 mi)) out) (loop (+ i k))) ((char=? c #\s) (display (if (= k 1) (number->string se) (pad2 se)) out) (loop (+ i k))) ((char=? c #\a) (display (if (< hh 12) "AM" "PM") out) (loop (+ i k))) + ;; timezone — format-ms renders UTC, the HTTP zone is GMT: z/zzz -> GMT, + ;; Z (RFC822) -> +0000, X (ISO) -> Z. + ((char=? c #\z) (display "GMT" out) (loop (+ i k))) + ((char=? c #\Z) (display "+0000" out) (loop (+ i k))) + ((char=? c #\X) (display "Z" out) (loop (+ i k))) (else (write-char c out) (loop (+ i 1))))))) (get-output-string out)))) +;; --- SimpleDateFormat .parse: pattern-driven parse to epoch-ms (UTC/GMT) ------ +(define (month-from-name s) + (let ((m3 (ascii-string-down (substring s 0 (min 3 (string-length s)))))) + (let loop ((i 0)) + (cond ((= i 12) #f) + ((string=? (ascii-string-down (substring (vector-ref month-names i) 0 3)) m3) (+ i 1)) + (else (loop (+ i 1))))))) +(define (parse-ms pattern input) + (let ((pn (string-length pattern)) (inn (string-length input)) + (y 1970) (mo 1) (d 1) (hh 0) (mi 0) (ss 0) (pm 'none)) + (define (pfail) (error #f (string-append "ParseException: unparseable date \"" input "\""))) + (define (run-len i c) (let loop ((j i)) (if (and (< j pn) (char=? (string-ref pattern j) c)) (loop (+ j 1)) (- j i)))) + (define (read-digits ii) ; -> (val . next), pfail if none + (let loop ((j ii) (acc 0) (any #f)) + (if (and (< j inn) (digit? (string-ref input j))) + (loop (+ j 1) (+ (* acc 10) (- (char->integer (string-ref input j)) 48)) #t) + (if any (cons acc j) (pfail))))) + (define (read-alpha ii) ; -> (str . next) + (let loop ((j ii)) (if (and (< j inn) (char-alphabetic? (string-ref input j))) (loop (+ j 1)) + (cons (substring input ii j) j)))) + (define (read-tz ii) ; consume GMT/UTC/Z or ±hhmm; -> next + (cond ((>= ii inn) ii) + ((char-alphabetic? (string-ref input ii)) (cdr (read-alpha ii))) + ((or (char=? (string-ref input ii) #\+) (char=? (string-ref input ii) #\-)) + (let loop ((j (+ ii 1))) (if (and (< j inn) (or (digit? (string-ref input j)) (char=? (string-ref input j) #\:))) (loop (+ j 1)) j))) + (else ii))) + (let loop ((pi 0) (ii 0)) + (if (>= pi pn) + (begin + (when (eq? pm 'pm) (when (< hh 12) (set! hh (+ hh 12)))) + (when (eq? pm 'am) (when (= hh 12) (set! hh 0))) + (make-jinst (* 1000 (+ (* (days-from-civil y mo d) 86400) (* hh 3600) (* mi 60) ss)))) + (let ((c (string-ref pattern pi))) + (cond + ((char-alphabetic? c) + (let ((k (run-len pi c))) + (cond + ((char=? c #\y) (let ((r (read-digits ii))) + ;; 2-digit year (value < 100): JVM sliding window — 00-68 -> 20xx, + ;; 69-99 -> 19xx (rfc1036 HTTP dates). A full year stays as-is. + (set! y (let ((v (car r))) (if (< v 100) (if (< v 69) (+ 2000 v) (+ 1900 v)) v))) + (loop (+ pi k) (cdr r)))) + ((char=? c #\M) (if (>= k 3) + (let ((r (read-alpha ii))) (set! mo (or (month-from-name (car r)) (pfail))) (loop (+ pi k) (cdr r))) + (let ((r (read-digits ii))) (set! mo (car r)) (loop (+ pi k) (cdr r))))) + ((char=? c #\d) (let ((r (read-digits ii))) (set! d (car r)) (loop (+ pi k) (cdr r)))) + ((or (char=? c #\H) (char=? c #\h)) (let ((r (read-digits ii))) (set! hh (car r)) (loop (+ pi k) (cdr r)))) + ((char=? c #\m) (let ((r (read-digits ii))) (set! mi (car r)) (loop (+ pi k) (cdr r)))) + ((char=? c #\s) (let ((r (read-digits ii))) (set! ss (car r)) (loop (+ pi k) (cdr r)))) + ((char=? c #\E) (loop (+ pi k) (cdr (read-alpha ii)))) + ((char=? c #\a) (let ((r (read-alpha ii))) + (set! pm (if (string=? (ascii-string-down (car r)) "pm") 'pm 'am)) + (loop (+ pi k) (cdr r)))) + ((or (char=? c #\z) (char=? c #\Z) (char=? c #\X)) (loop (+ pi k) (read-tz ii))) + (else (loop (+ pi k) ii))))) + ((char=? c #\') + (if (and (< (+ pi 1) pn) (char=? (string-ref pattern (+ pi 1)) #\')) + (loop (+ pi 2) (if (and (< ii inn) (char=? (string-ref input ii) #\')) (+ ii 1) ii)) + (let lit ((pj (+ pi 1)) (ij ii)) + (cond ((>= pj pn) (loop pj ij)) + ((char=? (string-ref pattern pj) #\') (loop (+ pj 1) ij)) + ((and (< ij inn) (char=? (string-ref input ij) (string-ref pattern pj))) (lit (+ pj 1) (+ ij 1))) + (else (pfail)))))) + ;; literal: match it; a pattern space tolerates missing/extra spaces. + ((char=? c #\space) + (let skip ((ij ii)) (if (and (< ij inn) (char=? (string-ref input ij) #\space)) (skip (+ ij 1)) (loop (+ pi 1) ij)))) + ((and (< ii inn) (char=? (string-ref input ii) c)) (loop (+ pi 1) (+ ii 1))) + (else (pfail)))))))) + ;; --- value integration: get / = / hash / pr / type / instance? -------------- (define kw-jolt-type (keyword "jolt" "type")) (define kw-ms (keyword #f "ms")) @@ -303,6 +377,10 @@ (register-class-ctor! "java.text.SimpleDateFormat" sdf-ctor) (register-host-methods! "sdf" (list (cons "setTimeZone" (lambda (self tz) jolt-nil)) + (cons "setLenient" (lambda (self b) jolt-nil)) + (cons "applyPattern" (lambda (self p) (vector-set! (jhost-state self) 0 (jolt-str-render-one p)) jolt-nil)) + (cons "toPattern" (lambda (self) (vector-ref (jhost-state self) 0))) + (cons "parse" (lambda (self s) (parse-ms (vector-ref (jhost-state self) 0) (jolt-str-render-one s)))) (cons "format" (lambda (self d) (format-ms (vector-ref (jhost-state self) 0) (ms-of d)))))) ;; a jinst's java.util.Date method surface (record-method-dispatch arm). @@ -313,6 +391,13 @@ ((jinst? obj) (cond ((string=? method-name "getTime") (jinst-ms obj)) ((string=? method-name "toInstant") (mk-instant (jinst-ms obj))) + ((string=? method-name "toLocalDate") (mk-local (jinst-ms obj))) + ((string=? method-name "toLocalDateTime") (mk-local (jinst-ms obj))) ((string=? method-name "toString") (inst-rfc3339 obj)) + ((string=? method-name "equals") (and (pair? (if (jolt-nil? rest-args) '() (seq->list rest-args))) + (jinst? (car (seq->list rest-args))) + (= (jinst-ms obj) (jinst-ms (car (seq->list rest-args)))))) + ((string=? method-name "before") (< (jinst-ms obj) (ms-of (car (seq->list rest-args))))) + ((string=? method-name "after") (> (jinst-ms obj) (ms-of (car (seq->list rest-args))))) (else (error #f (string-append "No method " method-name " on Date"))))) (else (%it-rmd obj method-name rest-args))))) diff --git a/host/chez/io.ss b/host/chez/io.ss index dd10774..562364e 100644 --- a/host/chez/io.ss +++ b/host/chez/io.ss @@ -130,6 +130,23 @@ (define (reader-jhost? x) (and (jhost? x) (member (jhost-tag x) '("string-reader" "pushback-reader")))) +;; Refill a host reader so subsequent read/slurp see `s` (the unconsumed tail). +(define (reader-refill! r s) + (cond + ((string=? (jhost-tag r) "string-reader") + (vector-set! (jhost-state r) 0 s) (vector-set! (jhost-state r) 1 0)) + ((string=? (jhost-tag r) "pushback-reader") + (vector-set! (jhost-state r) 0 (host-new "StringReader" s)) + (vector-set! (jhost-state r) 1 '())))) +;; Read ONE form from a host reader (StringReader/PushbackReader): drain the +;; remaining chars, parse one form, push the tail back. -> (values form found?). +;; (read r) over a java.io reader — cuerdas' interpolation reads this way. +(define (host-reader-read-form r) + (let* ((s (drain-reader r)) (pr (jolt-parse-next s))) + (if (jolt-nil? pr) + (begin (reader-refill! r "") (values jolt-nil #f)) + (begin (reader-refill! r (jolt-nth pr 1)) (values (jolt-nth pr 0) #t))))) + ;; clojure.edn/read over a reader (jolt-uicd): the overlay edn.clj's drain-reader is ;; janet/type-coupled, so on Chez we drain the jhost reader to a string and read the ;; first EDN form (read-string). Re-asserted over the prelude in post-prelude.ss. diff --git a/host/chez/post-prelude.ss b/host/chez/post-prelude.ss index 3d07011..c24ed96 100644 --- a/host/chez/post-prelude.ss +++ b/host/chez/post-prelude.ss @@ -101,3 +101,40 @@ ;; :jolt/deftype)) — the get-trick invokes a sorted-map's comparator on ;; :jolt/deftype and throws (jolt-3bbj). Matches the JVM (instance? IRecord). (def-var! "clojure.core" "record?" (lambda (x) (jrec? x))) + +;; read / read+string over a HOST reader jhost (java.io StringReader/PushbackReader): +;; the overlay's IReader protocol only covers the reify map-reader, so a (read +;; pushback-reader) — cuerdas' string interpolation — would miss. Intercept a host +;; reader; everything else (the *in* reify) delegates to the overlay. +(let ((ov-read (var-deref "clojure.core" "read"))) + (def-var! "clojure.core" "read" + (case-lambda + (() (jolt-invoke ov-read)) + ((stream) + (if (reader-jhost? stream) + (let-values (((form found?) (host-reader-read-form stream))) + (if found? form (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap))))) + (jolt-invoke ov-read stream))) + ((stream e? ev) + (if (reader-jhost? stream) + (let-values (((form found?) (host-reader-read-form stream))) + (cond (found? form) + ((jolt-truthy? e?) (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap)))) + (else ev))) + (jolt-invoke ov-read stream e? ev)))))) +(let ((ov-rps (var-deref "clojure.core" "read+string"))) + (def-var! "clojure.core" "read+string" + (case-lambda + (() (jolt-invoke ov-rps)) + ((stream) (jolt-invoke (var-deref "clojure.core" "read+string") stream #t jolt-nil)) + ((stream e? ev) + (if (reader-jhost? stream) + (let* ((s (drain-reader stream)) (pr (jolt-parse-next s))) + (if (jolt-nil? pr) + (begin (reader-refill! stream "") + (if (jolt-truthy? e?) (jolt-throw (jolt-ex-info "EOF while reading" (empty-pmap))) + (jolt-vector ev ""))) + (let ((rest (jolt-nth pr 1))) + (reader-refill! stream rest) + (jolt-vector (jolt-nth pr 0) (substring s 0 (- (string-length s) (string-length rest))))))) + (jolt-invoke ov-rps stream e? ev)))))) diff --git a/test/chez/unit.edn b/test/chez/unit.edn index 7c0e341..a6429ae 100644 --- a/test/chez/unit.edn +++ b/test/chez/unit.edn @@ -101,6 +101,13 @@ {:suite "hostctor" :expr "(instance? java.net.URI (java.net.URI. \"/x\"))" :expected "true"} {:suite "hostctor" :expr "(let [a (java.util.ArrayList.)] (.add a 1) (.add a 2) (.add a 3) (.remove a 0) [(.size a) (vec (.toArray a))])" :expected "[2 [2 3]]"} {:suite "hostctor" :expr "[(.indexOf [:a :b :c] :b) (.indexOf (list :a :b) :b) (.indexOf [:a] :z) (.indexOf (range 0 10) 1)]" :expected "[1 1 -1 1]"} + {:suite "sdf" :expr "(.format (java.text.SimpleDateFormat. \"EEE, dd MMM yyyy HH:mm:ss zzz\") (java.util.Date. 1348401170000))" :expected "Sun, 23 Sep 2012 11:52:50 GMT"} + {:suite "sdf" :expr "(.getTime (.parse (java.text.SimpleDateFormat. \"EEE, dd MMM yyyy HH:mm:ss zzz\") \"Sun, 23 Sep 2012 11:52:50 GMT\"))" :expected "1348401170000"} + {:suite "sdf" :expr "(.getTime (.parse (java.text.SimpleDateFormat. \"EEEE, dd-MMM-yy HH:mm:ss zzz\") \"Sunday, 23-Sep-12 11:52:50 GMT\"))" :expected "1348401170000"} + {:suite "sdf" :expr "(.getTime (.parse (java.text.SimpleDateFormat. \"EEE MMM d HH:mm:ss yyyy\") \"Sun Sep 23 11:52:50 2012\"))" :expected "1348401170000"} + {:suite "sdf" :expr "(let [f (java.text.SimpleDateFormat. \"yyyy-MM-dd\")] (.format f (.parse f \"2023-07-15\")))" :expected "2023-07-15"} + {:suite "reader" :expr "(let [r (-> \"foo bar baz\" java.io.StringReader. java.io.PushbackReader.)] [(read r) (slurp r)])" :expected "[foo bar baz]"} + {:suite "reader" :expr "(let [r (-> \"(+ 1 2) 99\" java.io.StringReader. java.io.PushbackReader.)] [(read r) (read r)])" :expected "[(+ 1 2) 99]"} {:suite "dotform" :expr "(.equals \"a\" \"a\")" :expected "true"} {:suite "dotform" :expr "(.equals \"a\" \"b\")" :expected "false"} {:suite "dotform" :expr "(. {:value 41 :describe (fn [self] (str \"v=\" (:value self)))} describe)" :expected "v=41"}