Merge pull request #194 from jolt-lang/spike/datajson-final
data.json: Calendar/java.time, java.sql.Date class, JVM-faithful Class value (suite 138/139)
This commit is contained in:
Dmitri Sotnikov
GitHub
commit
e94ddb2ffe
7 changed files with 135 additions and 21 deletions
|
|
@ -41,11 +41,17 @@
|
|||
;; (thrown? Class …) match (records.ss ex-info-map?/ex-info-class).
|
||||
((ex-info-map? x) (ex-info-class x))
|
||||
(else (jolt-str-render-one (jolt-type x)))))
|
||||
(define (jolt-class x)
|
||||
;; the class NAME of x (string), or nil for nil. (class x) wraps it in a Class
|
||||
;; value (make-class-obj, host-static-classes.ss) so it renders like a JVM Class
|
||||
;; while staying = its name string.
|
||||
(define (jolt-class-name x)
|
||||
(let loop ((as jolt-class-arms))
|
||||
(cond ((null? as) (jolt-class-base x))
|
||||
(((caar as) x) ((cdar as) x))
|
||||
(else (loop (cdr as))))))
|
||||
(define (jolt-class x)
|
||||
(let ((n (jolt-class-name x)))
|
||||
(if (jolt-nil? n) jolt-nil (make-class-obj n))))
|
||||
|
||||
(def-var! "clojure.core" "class" jolt-class)
|
||||
|
||||
|
|
|
|||
|
|
@ -643,5 +643,29 @@
|
|||
(else 'none))))
|
||||
(if (eq? hit 'none) 'pass (if hit #t #f))))))
|
||||
|
||||
;; java.lang.Class value: (class x) / (.getClass x) return one. It renders like
|
||||
;; the JVM — str/.toString -> "class <name>", pr -> "<name>", .getName -> "<name>"
|
||||
;; — but stays = and hash equal to its name STRING, so (= (class x) String),
|
||||
;; class-keyed maps/sets, multimethod dispatch on class, and instance? all keep
|
||||
;; working against the bare class-name tokens.
|
||||
(define (make-class-obj name) (make-jhost "class" (vector name)))
|
||||
(define (jclass? x) (and (jhost? x) (string=? (jhost-tag x) "class")))
|
||||
(define (jclass-name x) (vector-ref (jhost-state x) 0))
|
||||
(define (class-key x) (cond ((jclass? x) (jclass-name x)) ((string? x) x) (else #f)))
|
||||
(register-eq-arm! (lambda (a b) (or (jclass? a) (jclass? b)))
|
||||
(lambda (a b) (let ((ka (class-key a)) (kb (class-key b)))
|
||||
(and ka kb (string=? ka kb) #t))))
|
||||
(register-hash-arm! jclass? (lambda (x) (jolt-hash (jclass-name x))))
|
||||
(register-str-render! jclass? (lambda (x) (string-append "class " (jclass-name x))))
|
||||
(register-pr-arm! jclass? (lambda (x) (jclass-name x)))
|
||||
(register-host-methods! "class"
|
||||
(list (cons "getName" (lambda (self) (jclass-name self)))
|
||||
(cons "getCanonicalName" (lambda (self) (jclass-name self)))
|
||||
(cons "getSimpleName" (lambda (self) (hsc-last-segment (jclass-name self))))
|
||||
(cons "toString" (lambda (self) (string-append "class " (jclass-name self))))
|
||||
(cons "isArray" (lambda (self) (let ((n (jclass-name self)))
|
||||
(and (fx>? (string-length n) 0) (char=? (string-ref n 0) #\[)))))
|
||||
(cons "getClass" (lambda (self) (make-class-obj "java.lang.Class")))))
|
||||
|
||||
;; (jolt.host/table? x) — is x a host tagged-table?
|
||||
(def-var! "jolt.host" "table?" (lambda (x) (if (htable? x) #t #f)))
|
||||
|
|
|
|||
|
|
@ -245,7 +245,7 @@
|
|||
|
||||
;; java.time.Instant/ZonedDateTime/LocalDateTime values (mk-instant/mk-zoned/mk-local
|
||||
;; jhosts) are equal when same kind + same epoch-ms — two parsed Instants compare =.
|
||||
(define (time-jhost? x) (and (jhost? x) (member (jhost-tag x) '("instant" "zoned-dt" "local-dt")) #t))
|
||||
(define (time-jhost? x) (and (jhost? x) (member (jhost-tag x) '("instant" "zoned-dt" "local-dt" "local-date" "sql-date")) #t))
|
||||
(register-eq-arm! (lambda (a b) (or (time-jhost? a) (time-jhost? b)))
|
||||
(lambda (a b) (and (time-jhost? a) (time-jhost? b)
|
||||
(string=? (jhost-tag a) (jhost-tag b))
|
||||
|
|
@ -275,6 +275,9 @@
|
|||
(else 'pass)))
|
||||
((and (jhost? val) (string=? (jhost-tag val) "instant")) (if (string=? tn "Instant") #t 'pass))
|
||||
((and (jhost? val) (string=? (jhost-tag val) "local-dt")) (if (string=? tn "LocalDateTime") #t 'pass))
|
||||
;; java.sql.Date is a java.util.Date subclass (but not a Timestamp).
|
||||
((and (jhost? val) (string=? (jhost-tag val) "sql-date"))
|
||||
(cond ((or (string=? tn "Date")) #t) ((string=? tn "Timestamp") #f) (else 'pass)))
|
||||
(else 'pass)))))
|
||||
|
||||
;; inst-ms* is a seed native (the overlay inst-ms reads (get x :ms), now answered).
|
||||
|
|
@ -284,12 +287,16 @@
|
|||
(define (ms-of d)
|
||||
(cond ((number? d) d)
|
||||
((jinst? d) (jinst-ms d))
|
||||
((and (jhost? d) (member (jhost-tag d) '("instant" "zoned-dt" "local-dt")))
|
||||
((and (jhost? d) (member (jhost-tag d) '("instant" "zoned-dt" "local-dt" "local-date" "calendar" "sql-date")))
|
||||
(vector-ref (jhost-state d) 0))
|
||||
(else (error #f "not a date value" d))))
|
||||
(define (mk-instant ms) (make-jhost "instant" (vector ms)))
|
||||
(define (mk-zoned ms) (make-jhost "zoned-dt" (vector ms)))
|
||||
(define (mk-local ms) (make-jhost "local-dt" (vector ms)))
|
||||
(define (mk-local-date ms) (make-jhost "local-date" (vector ms)))
|
||||
;; start of the UTC day containing ms.
|
||||
(define (start-of-utc-day ms)
|
||||
(* (inst-floor-div (exact (truncate ms)) 86400000) 86400000))
|
||||
(define (mk-formatter pat) (make-jhost "dt-formatter" (vector pat)))
|
||||
(define (fmt-pat f) (vector-ref (jhost-state f) 0))
|
||||
(define (now-ms) (now-millis)) ; exact ms (= JVM long); now-millis from host-static.ss
|
||||
|
|
@ -304,10 +311,19 @@
|
|||
(list (cons "toLocalDateTime" (lambda (self) (mk-local (ms-of self))))
|
||||
(cons "toInstant" (lambda (self) (mk-instant (ms-of self))))))
|
||||
(register-host-methods! "local-dt"
|
||||
(list (cons "atZone" (lambda (self zone) (mk-zoned (ms-of self))))))
|
||||
(list (cons "atZone" (lambda (self zone) (mk-zoned (ms-of self))))
|
||||
(cons "toLocalDate" (lambda (self) (mk-local-date (ms-of self))))))
|
||||
;; LocalDate.atStartOfDay(zone): midnight of the UTC day (the layer is UTC).
|
||||
(register-host-methods! "local-date"
|
||||
(list (cons "atStartOfDay" (lambda (self . zone) (mk-zoned (start-of-utc-day (ms-of self)))))
|
||||
(cons "atZone" (lambda (self zone) (mk-zoned (ms-of self))))))
|
||||
(register-host-methods! "dt-formatter"
|
||||
(list (cons "withLocale" (lambda (self locale) (mk-formatter (fmt-pat self))))
|
||||
(cons "format" (lambda (self d) (format-ms (fmt-pat self) (ms-of d))))))
|
||||
(cons "withZone" (lambda (self zone) (mk-formatter (fmt-pat self))))
|
||||
(cons "format" (lambda (self d) (format-ms (fmt-pat self) (ms-of d))))
|
||||
;; parse a string per the pattern -> an instant value; Instant/from / the
|
||||
;; LocalDateTime/parse static read its ms back out.
|
||||
(cons "parse" (lambda (self s) (mk-instant (jinst-ms (parse-ms (fmt-pat self) (jolt-str-render-one s))))))))
|
||||
|
||||
;; FormatStyle approximations (no locale DB on this host).
|
||||
(define style-patterns
|
||||
|
|
@ -331,6 +347,8 @@
|
|||
(cons "ISO_LOCAL_DATE_TIME" (mk-formatter "yyyy-MM-dd'T'HH:mm:ss"))
|
||||
;; ISO_INSTANT always renders in UTC with a trailing Z (format-ms is UTC; X -> "Z").
|
||||
(cons "ISO_INSTANT" (mk-formatter "yyyy-MM-dd'T'HH:mm:ssX"))
|
||||
;; ISO_ZONED_DATE_TIME: the UTC layer renders/parses it like ISO_INSTANT.
|
||||
(cons "ISO_ZONED_DATE_TIME" (mk-formatter "yyyy-MM-dd'T'HH:mm:ssX"))
|
||||
(cons "ofLocalizedDate" (lambda (fs) (style-fmt 'date fs)))
|
||||
(cons "ofLocalizedTime" (lambda (fs) (style-fmt 'time fs)))
|
||||
(cons "ofLocalizedDateTime" (lambda (fs) (style-fmt 'datetime fs)))))
|
||||
|
|
@ -339,13 +357,22 @@
|
|||
(cons "now" (lambda () (mk-instant (now-ms))))
|
||||
;; Instant/parse an ISO-8601 instant ("…T…Z") -> an instant value.
|
||||
(cons "parse" (lambda (s) (mk-instant (jinst-ms (jolt-inst-from-string
|
||||
(if (string? s) s (jolt-str-render-one s)))))))))
|
||||
(if (string? s) s (jolt-str-render-one s)))))))
|
||||
;; Instant/from a temporal accessor -> an instant at the same epoch-ms.
|
||||
(cons "from" (lambda (t) (mk-instant (ms-of t))))))
|
||||
(register-class-statics! "ZoneId"
|
||||
(list (cons "systemDefault" (lambda () (make-jhost "zone-id" (vector "system"))))
|
||||
(cons "of" (lambda (id) (make-jhost "zone-id" (vector id))))))
|
||||
(register-class-statics! "LocalDateTime"
|
||||
(list (cons "ofInstant" (lambda (inst zone) (mk-local (ms-of inst))))
|
||||
(cons "now" (lambda () (mk-local (now-ms))))))
|
||||
(cons "now" (lambda () (mk-local (now-ms))))
|
||||
;; LocalDateTime/parse text, or text + a formatter (the UTC layer ignores
|
||||
;; the parsed offset) -> a local-dt at the parsed instant.
|
||||
(cons "parse" (lambda (s . fmt)
|
||||
(let ((str (if (string? s) s (jolt-str-render-one s))))
|
||||
(mk-local (jinst-ms (if (null? fmt)
|
||||
(jolt-inst-from-string str)
|
||||
(parse-ms (fmt-pat (car fmt)) str)))))))))
|
||||
(let ((locale-ctor (lambda (id . _) (make-jhost "locale" (vector (if (string? id) id (jolt-str-render-one id)))))))
|
||||
(register-class-ctor! "Locale" locale-ctor)
|
||||
(register-class-ctor! "java.util.Locale" locale-ctor))
|
||||
|
|
@ -364,15 +391,64 @@
|
|||
(register-class-ctor! "java.util.Date" date-ctor)
|
||||
(register-class-ctor! "Timestamp" date-ctor)
|
||||
(register-class-ctor! "java.sql.Timestamp" date-ctor)
|
||||
;; java.sql.Date: (Date. year-1900 month0 day) builds UTC midnight of that civil
|
||||
;; date; valueOf parses "yyyy-MM-dd" to the same instant (so the two agree).
|
||||
(define (sql-date-midnight y mo d) (make-jinst (* 1000 (* (days-from-civil y mo d) 86400))))
|
||||
;; java.sql.Date: a distinct class from java.util.Date (a "sql-date" jhost over
|
||||
;; epoch-ms) so a protocol extended to both routes a sql.Date to its own impl.
|
||||
;; (Date. year-1900 month0 day) builds UTC midnight of that civil date; valueOf
|
||||
;; parses "yyyy-MM-dd" to the same instant (so the two agree).
|
||||
(define (mk-sql-date ms) (make-jhost "sql-date" (vector (ms->exact ms))))
|
||||
(define (sql-date-midnight y mo d) (mk-sql-date (* 1000 (* (days-from-civil y mo d) 86400))))
|
||||
(register-class-ctor! "java.sql.Date"
|
||||
(case-lambda
|
||||
((ms) (make-jinst (ms->exact (ms-of ms)))) ; (Date. epoch-ms)
|
||||
((ms) (mk-sql-date (ms-of ms))) ; (Date. epoch-ms)
|
||||
((y m d) (sql-date-midnight (+ 1900 (jnum->exact y)) (+ 1 (jnum->exact m)) (jnum->exact d)))))
|
||||
(register-class-statics! "java.sql.Date"
|
||||
(list (cons "valueOf" (lambda (s) (parse-ms "yyyy-MM-dd" (if (string? s) s (jolt-str-render-one s)))))))
|
||||
(list (cons "valueOf" (lambda (s) (mk-sql-date (jinst-ms (parse-ms "yyyy-MM-dd" (if (string? s) s (jolt-str-render-one s)))))))))
|
||||
(register-host-methods! "sql-date"
|
||||
(list (cons "getTime" (lambda (self) (ms-of self)))
|
||||
(cons "toInstant" (lambda (self) (mk-instant (ms-of self))))
|
||||
(cons "toLocalDate" (lambda (self) (mk-local-date (ms-of self))))
|
||||
(cons "toString" (lambda (self) (inst-rfc3339 (make-jinst (ms-of self)))))))
|
||||
|
||||
;; java.util.Calendar: a mutable broken-down UTC time over an epoch-ms. setTime/
|
||||
;; getTime read/write it; set(field,value) recomputes ms from the field projection.
|
||||
;; Field constants are Java's int values so .set/.get dispatch on the right field.
|
||||
(define cal-YEAR 1) (define cal-MONTH 2) (define cal-DAY_OF_MONTH 5)
|
||||
(define cal-HOUR_OF_DAY 11) (define cal-MINUTE 12) (define cal-SECOND 13)
|
||||
(define cal-MILLISECOND 14)
|
||||
(define (cal-ms->fields ms) ; -> vector [y mo0 d hh mi ss frac] (MONTH 0-based, JVM)
|
||||
(let ((f (inst-fields ms)))
|
||||
(vector (list-ref f 0) (- (list-ref f 1) 1) (list-ref f 2)
|
||||
(list-ref f 3) (list-ref f 4) (list-ref f 5) (list-ref f 6))))
|
||||
(define (cal-fields->ms v)
|
||||
(+ (* 1000 (+ (* (days-from-civil (vector-ref v 0) (+ 1 (vector-ref v 1)) (vector-ref v 2)) 86400)
|
||||
(* (vector-ref v 3) 3600) (* (vector-ref v 4) 60) (vector-ref v 5)))
|
||||
(vector-ref v 6)))
|
||||
(define (cal-field-index fld)
|
||||
(cond ((= fld cal-YEAR) 0) ((= fld cal-MONTH) 1) ((= fld cal-DAY_OF_MONTH) 2)
|
||||
((= fld cal-HOUR_OF_DAY) 3) ((= fld cal-MINUTE) 4) ((= fld cal-SECOND) 5)
|
||||
((= fld cal-MILLISECOND) 6) (else #f)))
|
||||
(register-host-methods! "calendar"
|
||||
(list (cons "setTime" (lambda (self d) (vector-set! (jhost-state self) 0 (ms->exact (ms-of d))) jolt-nil))
|
||||
(cons "getTime" (lambda (self) (make-jinst (vector-ref (jhost-state self) 0))))
|
||||
(cons "getTimeInMillis" (lambda (self) (vector-ref (jhost-state self) 0)))
|
||||
(cons "setTimeInMillis" (lambda (self ms) (vector-set! (jhost-state self) 0 (ms->exact ms)) jolt-nil))
|
||||
(cons "set" (lambda (self field val)
|
||||
(let ((v (cal-ms->fields (vector-ref (jhost-state self) 0)))
|
||||
(idx (cal-field-index (jnum->exact field))))
|
||||
(when idx (vector-set! v idx (jnum->exact val))
|
||||
(vector-set! (jhost-state self) 0 (cal-fields->ms v)))
|
||||
jolt-nil)))
|
||||
(cons "get" (lambda (self field)
|
||||
(let ((v (cal-ms->fields (vector-ref (jhost-state self) 0)))
|
||||
(idx (cal-field-index (jnum->exact field))))
|
||||
(if idx (vector-ref v idx) 0))))))
|
||||
(define calendar-statics
|
||||
(list (cons "getInstance" (lambda _ (make-jhost "calendar" (vector (now-ms)))))
|
||||
(cons "YEAR" cal-YEAR) (cons "MONTH" cal-MONTH) (cons "DAY_OF_MONTH" cal-DAY_OF_MONTH)
|
||||
(cons "HOUR_OF_DAY" cal-HOUR_OF_DAY) (cons "MINUTE" cal-MINUTE)
|
||||
(cons "SECOND" cal-SECOND) (cons "MILLISECOND" cal-MILLISECOND)))
|
||||
(register-class-statics! "Calendar" calendar-statics)
|
||||
(register-class-statics! "java.util.Calendar" calendar-statics)
|
||||
|
||||
;; java.util.TimeZone: an opaque id holder (format-ms is UTC, so a non-UTC zone is
|
||||
;; not honored — only the UTC case the corpus uses is exercised).
|
||||
|
|
@ -404,7 +480,7 @@
|
|||
((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 "toLocalDate") (mk-local-date (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)))
|
||||
|
|
|
|||
|
|
@ -72,11 +72,10 @@
|
|||
((ex-info-map? val) (exception-isa? (last-dot (ex-info-class val)) (last-dot tname)))
|
||||
(else (case-string tname val)))))
|
||||
|
||||
(define (instance-check type-sym val)
|
||||
;; normalize a bare (non-array) string class token to a symbol so every arm and
|
||||
;; the base table can read its name; array tokens ("[I") stay strings for the
|
||||
;; natives-array arm.
|
||||
(let ((ts (if (and (string? type-sym)
|
||||
(define (instance-check type-sym0 val)
|
||||
;; a Class value as the type arg (instance? (class x) y) -> use its name string.
|
||||
(let* ((type-sym (if (jclass? type-sym0) (jclass-name type-sym0) type-sym0))
|
||||
(ts (if (and (string? type-sym)
|
||||
(or (= 0 (string-length type-sym))
|
||||
(not (char=? (string-ref type-sym 0) #\[))))
|
||||
(jolt-symbol #f type-sym)
|
||||
|
|
|
|||
|
|
@ -141,6 +141,9 @@
|
|||
((jinst? obj) '("Date" "java.util.Date" "Timestamp" "java.sql.Timestamp" "Object"))
|
||||
((jbigdec? obj) '("BigDecimal" "java.math.BigDecimal" "Number" "Object"))
|
||||
((and (jhost? obj) (string=? (jhost-tag obj) "instant")) '("Instant" "java.time.Instant" "Object"))
|
||||
;; java.sql.Date — a distinct class from java.util.Date so a protocol
|
||||
;; extended to both (data.json's JSONWriter) routes a sql.Date to its impl.
|
||||
((and (jhost? obj) (string=? (jhost-tag obj) "sql-date")) '("java.sql.Date" "Date" "java.util.Date" "Object"))
|
||||
;; a bare procedure (fn) — extend-protocol to clojure.lang.{Fn,IFn,AFn}.
|
||||
((procedure? obj) '("Fn" "IFn" "AFn" "Object"))
|
||||
((jolt-nil? obj) '("nil"))
|
||||
|
|
@ -192,7 +195,7 @@
|
|||
"ASeq" "ISeq" "IPersistentCollection" "Associative" "Sequential"
|
||||
"Map" "java.util.Map" "List" "java.util.List" "Set" "java.util.Set"
|
||||
"Collection" "java.util.Collection"
|
||||
"UUID" "BigDecimal" "Date" "Timestamp" "Instant"))
|
||||
"UUID" "BigDecimal" "Date" "Timestamp" "Instant" "java.sql.Date"))
|
||||
h))
|
||||
(define (strip-prefix s p)
|
||||
(let ((pl (string-length p)))
|
||||
|
|
|
|||
|
|
@ -74,8 +74,9 @@
|
|||
(let [w (last-seg wanted)]
|
||||
(if (or (= w "Exception") (= w "Throwable"))
|
||||
true
|
||||
(let [c (class e)]
|
||||
(and (string? c) (= (last-seg c) w))))))
|
||||
(let [c (class e)
|
||||
cn (cond (nil? c) nil (string? c) c :else (.getName c))]
|
||||
(and cn (= (last-seg cn) w))))))
|
||||
|
||||
;; --- assertion macros ------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -548,6 +548,11 @@
|
|||
{:suite "host-interop / class tokens & readers" :label "(class x) matches the token" :expected "true" :actual "(= String (class \"abc\"))"}
|
||||
{:suite "host-interop / class tokens & readers" :label "defmulti on class dispatches" :expected ":str" :actual "(do (defmulti cm (fn [x] (class x))) (defmethod cm String [x] :str) (cm \"a\"))"}
|
||||
{:suite "host-interop / class tokens & readers" :label "defmethod on nil dispatch value" :expected ":nil" :actual "(do (defmulti cn (fn [x] (class x))) (defmethod cn nil [x] :nil) (defmethod cn String [x] :str) (cn nil))"}
|
||||
{:suite "host-interop / class tokens & readers" :label "Class str is class-prefixed" :expected "\"class java.lang.String\"" :actual "(str (class \"\"))"}
|
||||
{:suite "host-interop / class tokens & readers" :label "Class getName" :expected "\"java.lang.String\"" :actual "(.getName (class \"\"))"}
|
||||
{:suite "host-interop / class tokens & readers" :label "Class getSimpleName" :expected "\"Long\"" :actual "(.getSimpleName (class 5))"}
|
||||
{:suite "host-interop / class tokens & readers" :label "Class of equal-typed values is =" :expected "true" :actual "(= (class 5) (class 6))"}
|
||||
{:suite "host-interop / class tokens & readers" :label "Class in a thrown message" :expected "\"of class java.lang.String\"" :actual "(try (throw (Exception. (str \"of \" (class \"\")))) (catch Exception e (.getMessage e)))"}
|
||||
{:suite "host-interop / class tokens & readers" :label "ctor sugar still constructs" :expected "\"x\"" :actual "(.toString (StringBuilder. \"x\"))"}
|
||||
{:suite "host-interop / class tokens & readers" :label "return-hinted defn parses" :expected "7" :actual "(do (defn- hb ^bytes [b] b) (hb 7))"}
|
||||
{:suite "host-interop / class tokens & readers" :label "hinted multi-arity parses" :expected ":two" :actual "((fn ([x] :one) (^String [x y] :two)) 1 2)"}
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue