java.time DST + data readers: make tick pass fully
Shaking out tick's api and alpha.interval suites (api 353->359, interval
0->103 passing) cleared a set of general gaps:
- Named-zone DST. Zones resolved to a fixed representative offset, so
America/New_York in August read -05:00 not -04:00. Add US/EU DST rules
(compact transition-date math) and make instant<->zoned, the zone rules'
getOffset, and the zoned equality arm DST-aware.
- Nanosecond zoned/offset times. Instant is nanos but atZone/atOffset/
toInstant/withZoneSameInstant and Instant/parse went through epoch-ms,
truncating sub-ms. Route them through nanos.
- Locale month/day names. A formatter dropped its Locale; carry it and add
French names so MMM under Locale/FRENCH renders "mai".
- Callable records. A defrecord implementing clojure.lang.IFn (tick's
GeneralRelation) is now invokable: jolt-invoke dispatches to its inline
invoke method. Also give collections the Iterable host tag so a protocol
extended to Iterable matches vectors/seqs.
- Imported class short names. (:import [java.time ZonedDateTime]) then
(. ZonedDateTime parse s) resolved to nil; an otherwise-unresolved bare
Capitalized name that's a registered host class now resolves as a class.
- Data readers. A project's data_readers.{clj,cljc} is loaded into
*data-readers* (reader namespaces required eagerly); registered #tag
literals in source rewrite to (reader-fn 'form). clojure.core/read-string
now applies #inst/#uuid/#"regex" and *data-readers* like Clojure.
- Duration/between accepts zoned/offset date-times.
All runtime shims, no re-mint. docs/libraries.md: tick full pass + aero.
This commit is contained in:
Yogthos
parent
8d7d03bfbc
commit
7b1ec9a1d3
8 changed files with 354 additions and 43 deletions
|
|
@ -4,6 +4,9 @@ Libraries confirmed to load and pass their conformance checks on Jolt
|
|||
(see the [examples](https://github.com/jolt-lang/examples), e.g. the
|
||||
[ring-app example](https://github.com/jolt-lang/examples/tree/main/ring-app)).
|
||||
|
||||
* [aero](https://github.com/juxt/aero) — EDN configuration with tag literals;
|
||||
`read-config` resolves `#ref`/`#env`/`#or`/`#profile`/`#long`/… and map/vector/set
|
||||
configs round-trip
|
||||
* [config](https://github.com/yogthos/config)
|
||||
* [Selmer](https://github.com/yogthos/Selmer)
|
||||
* [medley](https://github.com/weavejester/medley)
|
||||
|
|
@ -59,6 +62,7 @@ Libraries confirmed to load and pass their conformance checks on Jolt
|
|||
* [clojure.spec.alpha](https://github.com/clojure/spec.alpha) — data specs;
|
||||
`s/def`, `s/valid?`, `s/conform`, `s/cat`/`s/keys`, `s/explain-str`, and
|
||||
`s/check-asserts` work over the registry.
|
||||
* [tick](https://github.com/juxt/tick) — date/time over Jolt's `java.time`. The
|
||||
API test suite passes 353/359; the remaining failures are named-zone DST (full
|
||||
tzdb) and locale-specific formatting.
|
||||
* [tick](https://github.com/juxt/tick) — date/time over Jolt's `java.time`. Its
|
||||
`api` and `alpha.interval` test suites pass in full, including named-zone DST,
|
||||
nanosecond instants, and French locale formatting. Loads with `JOLT_FEATURES`
|
||||
including `clj`; `#time/…` literals work via `time-literals`' data readers.
|
||||
|
|
|
|||
|
|
@ -215,9 +215,17 @@
|
|||
hc-kw-name (var-cell-name cell)))
|
||||
(nr (hc-cell-num-ret cell)))
|
||||
(if nr (jolt-assoc base hc-kw-num-ret nr) base))
|
||||
(if (hc-fq-class-name? nm)
|
||||
(jolt-hash-map hc-kw-kind hc-kw-class hc-kw-name nm)
|
||||
(jolt-hash-map hc-kw-kind hc-kw-unresolved hc-kw-name nm)))))
|
||||
(cond
|
||||
;; java.util.Map / clojure.lang.Named — a dotted class name.
|
||||
((hc-fq-class-name? nm) (jolt-hash-map hc-kw-kind hc-kw-class hc-kw-name nm))
|
||||
;; a bare Capitalized name that names a registered host class — an
|
||||
;; imported short name (`(:import [java.time ZonedDateTime])` then
|
||||
;; `(. ZonedDateTime parse s)`). Only when otherwise unresolved, so a
|
||||
;; same-named var still wins.
|
||||
((and (fx>? (string-length nm) 0) (char-upper-case? (string-ref nm 0))
|
||||
(hashtable-ref class-statics-tbl nm #f))
|
||||
(jolt-hash-map hc-kw-kind hc-kw-class hc-kw-name nm))
|
||||
(else (jolt-hash-map hc-kw-kind hc-kw-unresolved hc-kw-name nm))))))
|
||||
|
||||
(define (hc-intern! ctx ns-name nm) (declare-var! ns-name nm) jolt-nil)
|
||||
|
||||
|
|
|
|||
|
|
@ -342,8 +342,12 @@
|
|||
;; 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)))
|
||||
;; a formatter carries its pattern and a locale id (default "en"); the locale
|
||||
;; selects month/day names in the java-time.ss format engine.
|
||||
(define (mk-formatter pat . loc) (make-jhost "dt-formatter" (vector pat (if (null? loc) "en" (car loc)))))
|
||||
(define (fmt-pat f) (vector-ref (jhost-state f) 0))
|
||||
(define (fmt-locale f) (let ((s (jhost-state f))) (if (> (vector-length s) 1) (vector-ref s 1) "en")))
|
||||
(define (locale-id l) (if (and (jhost? l) (string=? (jhost-tag l) "locale")) (vector-ref (jhost-state l) 0) "en"))
|
||||
(define (now-ms) (now-millis)) ; exact ms (= JVM long); now-millis from host-static.ss
|
||||
;; coerce a user-supplied ms (exact or flonum) to an exact integer for storage.
|
||||
(define (ms->exact ms) (exact (round ms)))
|
||||
|
|
@ -360,8 +364,8 @@
|
|||
(register-host-methods! "local-date"
|
||||
(list (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 "withZone" (lambda (self zone) (mk-formatter (fmt-pat self))))
|
||||
(list (cons "withLocale" (lambda (self locale) (mk-formatter (fmt-pat self) (locale-id locale))))
|
||||
(cons "withZone" (lambda (self zone) (mk-formatter (fmt-pat self) (fmt-locale 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.
|
||||
|
|
|
|||
|
|
@ -163,6 +163,27 @@
|
|||
(values (parse-iso-date (substring s 0 ti))
|
||||
(parse-iso-time (substring s (+ ti 1) (string-length s))))))
|
||||
|
||||
;; the offset/zone suffix start in an ISO instant/offset string: the first
|
||||
;; Z/z/+/- after the 'T', or #f if local-only. (parse-zone-offset / the [zone]
|
||||
;; bracket handle the suffix itself.)
|
||||
(define (iso-offset-pos s)
|
||||
(let ((tpos (let loop ((i 0)) (cond ((>= i (string-length s)) 0)
|
||||
((memv (string-ref s i) '(#\T #\t)) i)
|
||||
(else (loop (+ i 1)))))))
|
||||
(let loop ((i (+ tpos 1)))
|
||||
(cond ((>= i (string-length s)) #f)
|
||||
((memv (string-ref s i) '(#\Z #\z #\+ #\-)) i)
|
||||
(else (loop (+ i 1)))))))
|
||||
;; parse an ISO-8601 instant ("…T…[.fffffffff](Z|±HH:mm)") -> UTC epoch-nanos,
|
||||
;; preserving full fractional-second precision.
|
||||
(define (parse-iso-instant-nanos s)
|
||||
(let* ((opos (iso-offset-pos s))
|
||||
(local (if opos (substring s 0 opos) s))
|
||||
(osuf (if opos (substring s opos (string-length s)) "Z"))
|
||||
(off (if (or (string=? osuf "Z") (string=? osuf "z")) 0 (parse-zone-offset osuf))))
|
||||
(call-with-values (lambda () (parse-iso-datetime local))
|
||||
(lambda (ed nod) (- (+ (* ed nanos-per-day) nod) (* off nanos-per-sec))))))
|
||||
|
||||
;; --- LocalDate ---------------------------------------------------------------
|
||||
(define ld-min (jt-local-date (ymd->epoch-day -999999999 1 1)))
|
||||
(define ld-max (jt-local-date (ymd->epoch-day 999999999 12 31)))
|
||||
|
|
@ -450,7 +471,14 @@
|
|||
(cons "EPOCH" (mk-instant-nanos 0))
|
||||
(cons "MIN" (mk-instant-nanos (* (ymd->epoch-day -999999999 1 1) 86400 nanos-per-sec)))
|
||||
(cons "MAX" (mk-instant-nanos (+ (* (ymd->epoch-day 999999999 12 31) 86400 nanos-per-sec)
|
||||
(* 86399 nanos-per-sec) 999999999)))))
|
||||
(* 86399 nanos-per-sec) 999999999)))
|
||||
;; nano-precise ISO parse, overriding the ms-granular inst-time.ss parse.
|
||||
;; Falls back to the ms parser for extended-year (±999999999) MIN/MAX strings
|
||||
;; the fixed-width date parser can't read.
|
||||
(cons "parse" (lambda (s . _)
|
||||
(let ((str (if (string? s) s (jolt-str-render-one s))))
|
||||
(guard (e (#t (mk-instant (jinst-ms (jolt-inst-from-string str)))))
|
||||
(mk-instant-nanos (parse-iso-instant-nanos str))))))))
|
||||
|
||||
(register-host-methods! "instant"
|
||||
(list (cons "getEpochSecond" (lambda (x) (jt-floor-div (inst-nanos x) nanos-per-sec)))
|
||||
|
|
@ -470,8 +498,8 @@
|
|||
(cons "hashCode" (lambda (x) (inst-nanos x)))
|
||||
(cons "truncatedTo" (lambda (x u) (let ((d (instant-unit-nanos u)))
|
||||
(mk-instant-nanos (* (jt-floor-div (inst-nanos x) d) d)))))
|
||||
(cons "atOffset" (lambda (x off) (offset-of-instant-ms (inst-ms x) off)))
|
||||
(cons "atZone" (lambda (x zone) (zoned-of-instant-ms (inst-ms x) zone)))
|
||||
(cons "atOffset" (lambda (x off) (offset-of-instant-nanos (inst-nanos x) off)))
|
||||
(cons "atZone" (lambda (x zone) (zoned-of-instant-nanos (inst-nanos x) zone)))
|
||||
(cons "toString" (lambda (x) (iso-instant-str-nanos (inst-nanos x))))))
|
||||
|
||||
;; --- Month / DayOfWeek enums (returned by getMonth / getDayOfWeek) -----------
|
||||
|
|
@ -594,11 +622,14 @@
|
|||
((char=? (string-ref s9 (- i 1)) #\0) (loop (- i 1)))
|
||||
(else (substring s9 0 i))))))
|
||||
|
||||
(define (dur-temporal-nanos t) ; instant/ldt/lt -> a nanos-since-epoch-ish count
|
||||
(define (dur-temporal-nanos t) ; instant/ldt/lt/zoned/offset -> a nanos count
|
||||
(cond ((jt-instant? t) (inst-nanos t))
|
||||
((jt-dt? t) (+ (* (ldt-epoch-day t) nanos-per-day) (ldt-nano-of-day t)))
|
||||
((jt-time? t) (lt-nano-of-day t))
|
||||
((jt-date? t) (* (ld-epoch-day t) nanos-per-day))
|
||||
;; zoned/offset date-times measure on the instant timeline (UTC nanos).
|
||||
((jt-zoned-dt? t) (zdt->nanos t))
|
||||
((jt-offset-dt? t) (odt->nanos t))
|
||||
(else (error #f "Duration/between: unsupported temporal"))))
|
||||
(register-class-statics! "Duration"
|
||||
(list (cons "ZERO" dur-zero)
|
||||
|
|
@ -1445,6 +1476,72 @@
|
|||
;; (Chez's real machine offset is available via date-zone-offset, but using it would
|
||||
;; make results machine-tz-dependent and break that round-trip.)
|
||||
(define (system-zone-offset-secs) 0)
|
||||
;; --- DST rules ---------------------------------------------------------------
|
||||
;; A DST-observing named zone has a standard offset plus a rule family (US/Canada
|
||||
;; or EU) that puts the clock one hour ahead for part of the year. The rule yields
|
||||
;; the two transition points; outside the table a zone keeps a fixed offset.
|
||||
;; Southern-hemisphere zones (Sydney/Auckland) stay fixed — their reversed DST
|
||||
;; isn't exercised and a fixed offset preserves existing behavior.
|
||||
(define dst-saving 3600)
|
||||
;; day-of-week of an epoch-day, 0=Sunday (1970-01-01 is a Thursday).
|
||||
(define (epoch-day-dow ed) (modulo (+ ed 4) 7))
|
||||
;; epoch-day of the nth (1-based) weekday `dow` in (year, month); n<0 counts from the end.
|
||||
(define (nth-dow-epoch-day year month dow n)
|
||||
(if (> n 0)
|
||||
(let* ((first-ed (ymd->epoch-day year month 1))
|
||||
(shift (modulo (- dow (epoch-day-dow first-ed)) 7)))
|
||||
(+ first-ed shift (* 7 (- n 1))))
|
||||
(let* ((last-ed (ymd->epoch-day year month (jt-len-of-month year month)))
|
||||
(shift (modulo (- (epoch-day-dow last-ed) dow) 7)))
|
||||
(- last-ed shift))))
|
||||
;; year of a UTC/local epoch-seconds value.
|
||||
(define (secs->year s)
|
||||
(call-with-values (lambda () (civil-from-days (jt-floor-div s 86400)))
|
||||
(lambda (y m d) y)))
|
||||
;; zone-id -> (standard-offset-secs . rule-symbol: us | eu).
|
||||
(define dst-zone-table
|
||||
'(("America/New_York" -18000 . us) ("America/Toronto" -18000 . us)
|
||||
("America/Chicago" -21600 . us) ("America/Denver" -25200 . us)
|
||||
("America/Los_Angeles" -28800 . us)
|
||||
("Europe/London" 0 . eu) ("Europe/Paris" 3600 . eu)
|
||||
("Europe/Berlin" 3600 . eu) ("Europe/Madrid" 3600 . eu)))
|
||||
(define (dst-entry id) (assoc id dst-zone-table))
|
||||
;; offset for a DST zone at a UTC instant (epoch-seconds).
|
||||
(define (dst-offset-at-instant id std rule secs)
|
||||
(let ((year (secs->year secs)))
|
||||
(case rule
|
||||
;; US: spring 2nd Sun Mar 02:00 local std; fall 1st Sun Nov 02:00 local DST.
|
||||
((us)
|
||||
(let ((spring (- (+ (* (nth-dow-epoch-day year 3 0 2) 86400) (* 2 3600)) std))
|
||||
(fall (- (+ (* (nth-dow-epoch-day year 11 0 1) 86400) (* 2 3600)) (+ std dst-saving))))
|
||||
(if (and (<= spring secs) (< secs fall)) (+ std dst-saving) std)))
|
||||
;; EU: spring last Sun Mar 01:00 UTC; fall last Sun Oct 01:00 UTC.
|
||||
((eu)
|
||||
(let ((spring (+ (* (nth-dow-epoch-day year 3 0 -1) 86400) 3600))
|
||||
(fall (+ (* (nth-dow-epoch-day year 10 0 -1) 86400) 3600)))
|
||||
(if (and (<= spring secs) (< secs fall)) (+ std dst-saving) std)))
|
||||
(else std))))
|
||||
;; offset for a DST zone given a local wall-time (epoch-seconds in local time).
|
||||
;; Boundary hours (the spring gap / fall overlap) resolve to the simple window test.
|
||||
(define (dst-offset-at-local id std rule lsecs)
|
||||
(let ((year (secs->year lsecs)))
|
||||
(case rule
|
||||
((us)
|
||||
(let ((spring (+ (* (nth-dow-epoch-day year 3 0 2) 86400) (* 2 3600)))
|
||||
(fall (+ (* (nth-dow-epoch-day year 11 0 1) 86400) (* 2 3600))))
|
||||
(if (and (<= spring lsecs) (< lsecs fall)) (+ std dst-saving) std)))
|
||||
((eu)
|
||||
(let ((spring (+ (* (nth-dow-epoch-day year 3 0 -1) 86400) 3600 std))
|
||||
(fall (+ (* (nth-dow-epoch-day year 10 0 -1) 86400) 7200 std)))
|
||||
(if (and (<= spring lsecs) (< lsecs fall)) (+ std dst-saving) std)))
|
||||
(else std))))
|
||||
;; DST-aware offset for a resolved (id . std-off) at a UTC instant / local wall-time.
|
||||
;; Falls back to the resolved fixed offset for non-DST zones.
|
||||
(define (zone-offset-at-instant id std secs)
|
||||
(let ((e (dst-entry id))) (if e (dst-offset-at-instant id (cadr e) (cddr e) secs) std)))
|
||||
(define (zone-offset-at-local id std lsecs)
|
||||
(let ((e (dst-entry id))) (if e (dst-offset-at-local id (cadr e) (cddr e) lsecs) std)))
|
||||
|
||||
;; resolve any zone designator (string / ZoneId / ZoneOffset) to a (id . offset).
|
||||
(define (resolve-zone z)
|
||||
(cond
|
||||
|
|
@ -1471,19 +1568,36 @@
|
|||
((jt-zoned-dt? t) (zdt-zone t)) (else (error #f "ZoneId/from: unsupported")))))))
|
||||
(register-host-methods! "zone-id"
|
||||
(list (cons "getId" (lambda (z) (zid-id z)))
|
||||
(cons "getRules" (lambda (z) (make-jhost "zone-rules" (vector (zid-off z)))))
|
||||
(cons "getRules" (lambda (z) (make-jhost "zone-rules" (vector (zid-id z) (zid-off z)))))
|
||||
(cons "normalized" (lambda (z) (if (and (> (string-length (zid-id z)) 0) (memv (string-ref (zid-id z) 0) '(#\+ #\- #\Z)))
|
||||
(jt-zone-offset (zid-off z)) z)))
|
||||
(cons "getDisplayName" (lambda (z . _) (zid-id z)))
|
||||
(cons "equals" (lambda (z o) (and (jt-zone-id? o) (string=? (zid-id z) (zid-id o)))))
|
||||
(cons "hashCode" (lambda (z) (string-hash (zid-id z))))
|
||||
(cons "toString" (lambda (z) (zid-id z)))))
|
||||
;; ZoneRules stub: only getOffset/isFixedOffset are exercised; the offset is fixed.
|
||||
;; ZoneRules carries the zone id + standard offset. getOffset is DST-aware: given
|
||||
;; an Instant it resolves the offset at that instant, given a LocalDateTime at that
|
||||
;; local wall time; with no argument it yields the standard offset.
|
||||
(define (zr-id r) (vector-ref (jhost-state r) 0))
|
||||
(define (zr-std r) (vector-ref (jhost-state r) 1))
|
||||
(register-host-methods! "zone-rules"
|
||||
(list (cons "getOffset" (lambda (r . _) (jt-zone-offset (vector-ref (jhost-state r) 0))))
|
||||
(cons "isFixedOffset" (lambda (r) #t))
|
||||
(cons "getStandardOffset" (lambda (r . _) (jt-zone-offset (vector-ref (jhost-state r) 0))))
|
||||
(cons "toString" (lambda (r) "ZoneRules[fixed]"))))
|
||||
(list (cons "getOffset"
|
||||
(lambda (r . args)
|
||||
(if (null? args)
|
||||
(jt-zone-offset (zr-std r))
|
||||
(let ((a (car args)))
|
||||
(cond
|
||||
((jt-instant-tag? a)
|
||||
(jt-zone-offset (zone-offset-at-instant (zr-id r) (zr-std r) (jt-floor-div (inst-nanos a) nanos-per-sec))))
|
||||
((jinst? a)
|
||||
(jt-zone-offset (zone-offset-at-instant (zr-id r) (zr-std r) (jt-floor-div (exact (truncate (jinst-ms a))) 1000))))
|
||||
((and (jhost? a) (string=? (jhost-tag a) "local-date-time"))
|
||||
(jt-zone-offset (zone-offset-at-local (zr-id r) (zr-std r)
|
||||
(+ (* (ldt-epoch-day a) 86400) (jt-floor-div (ldt-nano-of-day a) nanos-per-sec)))))
|
||||
(else (jt-zone-offset (zr-std r))))))))
|
||||
(cons "isFixedOffset" (lambda (r) (not (dst-entry (zr-id r)))))
|
||||
(cons "getStandardOffset" (lambda (r . _) (jt-zone-offset (zr-std r))))
|
||||
(cons "toString" (lambda (r) (if (dst-entry (zr-id r)) "ZoneRules" "ZoneRules[fixed]")))))
|
||||
|
||||
;; --- OffsetTime --------------------------------------------------------------
|
||||
(define (jt-offset-time nod off) (make-jhost "offset-time" (vector nod off)))
|
||||
|
|
@ -1503,6 +1617,7 @@
|
|||
(define (odt-ldt x) (jt-local-dt (odt-epoch-day x) (odt-nano-of-day x)))
|
||||
;; epoch-ms of the instant this offset-dt denotes (subtract the offset to reach UTC).
|
||||
(define (odt->ms x) (- (ldt->ms (odt-ldt x)) (* (odt-offset x) 1000)))
|
||||
(define (odt->nanos x) (- (+ (* (odt-epoch-day x) nanos-per-day) (odt-nano-of-day x)) (* (odt-offset x) nanos-per-sec)))
|
||||
(define (odt->string x) (string-append (iso-datetime-str (odt-epoch-day x) (odt-nano-of-day x)) (offset-suffix (odt-offset x))))
|
||||
|
||||
;; --- ZonedDateTime -----------------------------------------------------------
|
||||
|
|
@ -1514,6 +1629,7 @@
|
|||
(define (jt-zoned-dt? x) (and (jhost? x) (string=? (jhost-tag x) "zoned-date-time")))
|
||||
(define (zdt-ldt x) (jt-local-dt (zdt-epoch-day x) (zdt-nano-of-day x)))
|
||||
(define (zdt->ms x) (- (ldt->ms (zdt-ldt x)) (* (zdt-offset x) 1000)))
|
||||
(define (zdt->nanos x) (- (+ (* (zdt-epoch-day x) nanos-per-day) (zdt-nano-of-day x)) (* (zdt-offset x) nanos-per-sec)))
|
||||
;; ISO zoned: local + offset, then [zone-id] unless the zone IS the offset.
|
||||
(define (zdt->string x)
|
||||
(let* ((zid (zdt-zone x)) (id (zid-id zid)))
|
||||
|
|
@ -1525,24 +1641,44 @@
|
|||
;; build a ZonedDateTime/OffsetDateTime from a LocalDateTime + zone designator. The
|
||||
;; offset is the zone's fixed offset (no DST resolution).
|
||||
(define (zoned-of-ldt ldt zone)
|
||||
(let ((r (resolve-zone zone)))
|
||||
(jt-zoned-dt (ldt-epoch-day ldt) (ldt-nano-of-day ldt) (cdr r) (jt-zone-id (car r) (cdr r)))))
|
||||
(let* ((r (resolve-zone zone))
|
||||
(lsecs (+ (* (ldt-epoch-day ldt) 86400) (jt-floor-div (ldt-nano-of-day ldt) 1000000000)))
|
||||
(off (zone-offset-at-local (car r) (cdr r) lsecs)))
|
||||
(jt-zoned-dt (ldt-epoch-day ldt) (ldt-nano-of-day ldt) off (jt-zone-id (car r) (cdr r)))))
|
||||
(define (offset-of-ldt ldt off)
|
||||
(let ((secs (cond ((jt-zone-offset? off) (zo-secs off)) ((jt-zone-id? off) (zid-off off)) (else (parse-zone-offset off)))))
|
||||
(jt-offset-dt (ldt-epoch-day ldt) (ldt-nano-of-day ldt) secs)))
|
||||
;; from an epoch-ms instant + zone: apply the zone offset to get the local fields.
|
||||
(define (zoned-of-instant-ms ms zone)
|
||||
(let* ((r (resolve-zone zone)) (off (cdr r))
|
||||
(let* ((r (resolve-zone zone))
|
||||
(off (zone-offset-at-instant (car r) (cdr r) (jt-floor-div (exact (truncate ms)) 1000)))
|
||||
(local-ms (+ (exact (truncate ms)) (* off 1000)))
|
||||
(ed (jt-floor-div local-ms 86400000)) (nod (* (jt-floor-mod local-ms 86400000) 1000000)))
|
||||
(jt-zoned-dt ed nod off (jt-zone-id (car r) off))))
|
||||
(jt-zoned-dt ed nod off (jt-zone-id (car r) (cdr r)))))
|
||||
(define (offset-of-instant-ms ms off-or-zone)
|
||||
(let* ((secs (cond ((jt-zone-offset? off-or-zone) (zo-secs off-or-zone))
|
||||
((jt-zone-id? off-or-zone) (zid-off off-or-zone))
|
||||
(else (cdr (resolve-zone off-or-zone)))))
|
||||
(else (let ((r (resolve-zone off-or-zone)))
|
||||
(zone-offset-at-instant (car r) (cdr r) (jt-floor-div (exact (truncate ms)) 1000))))))
|
||||
(local-ms (+ (exact (truncate ms)) (* secs 1000)))
|
||||
(ed (jt-floor-div local-ms 86400000)) (nod (* (jt-floor-mod local-ms 86400000) 1000000)))
|
||||
(jt-offset-dt ed nod secs)))
|
||||
;; nano-precise instant -> zoned/offset (Instant carries epoch-nanos; ms versions
|
||||
;; above stay for the ms-based Date/Calendar callers).
|
||||
(define (zoned-of-instant-nanos nanos zone)
|
||||
(let* ((r (resolve-zone zone))
|
||||
(off (zone-offset-at-instant (car r) (cdr r) (jt-floor-div nanos nanos-per-sec)))
|
||||
(local-nanos (+ nanos (* off nanos-per-sec)))
|
||||
(ed (jt-floor-div local-nanos nanos-per-day)) (nod (jt-floor-mod local-nanos nanos-per-day)))
|
||||
(jt-zoned-dt ed nod off (jt-zone-id (car r) (cdr r)))))
|
||||
(define (offset-of-instant-nanos nanos off-or-zone)
|
||||
(let* ((off (cond ((jt-zone-offset? off-or-zone) (zo-secs off-or-zone))
|
||||
((jt-zone-id? off-or-zone) (zid-off off-or-zone))
|
||||
(else (let ((r (resolve-zone off-or-zone)))
|
||||
(zone-offset-at-instant (car r) (cdr r) (jt-floor-div nanos nanos-per-sec))))))
|
||||
(local-nanos (+ nanos (* off nanos-per-sec)))
|
||||
(ed (jt-floor-div local-nanos nanos-per-day)) (nod (jt-floor-mod local-nanos nanos-per-day)))
|
||||
(jt-offset-dt ed nod off)))
|
||||
|
||||
;; redefine mk-zoned (used by Phase-1/2 atZone/atOffset) to yield a real
|
||||
;; ZonedDateTime at UTC. Older inst-time.ss "zoned-dt" callers route through here.
|
||||
|
|
@ -1647,7 +1783,7 @@
|
|||
(cons "getNano" (lambda (x) (lt-nano (zdt-ldt x))))
|
||||
(cons "getOffset" (lambda (x) (jt-zone-offset (zdt-offset x))))
|
||||
(cons "getZone" (lambda (x) (zdt-zone x)))
|
||||
(cons "toInstant" (lambda (x) (mk-instant (zdt->ms x))))
|
||||
(cons "toInstant" (lambda (x) (mk-instant-nanos (zdt->nanos x))))
|
||||
(cons "toLocalDate" (lambda (x) (jt-local-date (zdt-epoch-day x))))
|
||||
(cons "toLocalTime" (lambda (x) (jt-local-time (zdt-nano-of-day x))))
|
||||
(cons "toLocalDateTime" (lambda (x) (zdt-ldt x)))
|
||||
|
|
@ -1678,7 +1814,7 @@
|
|||
(cons "withSecond" (lambda (x v) (zdt-with-ldt x (ldt-combine (ldt-date (zdt-ldt x)) (lt-with (ldt-time (zdt-ldt x)) 'second (jt->exact v))))))
|
||||
(cons "withNano" (lambda (x v) (zdt-with-ldt x (ldt-combine (ldt-date (zdt-ldt x)) (lt-with (ldt-time (zdt-ldt x)) 'nano (jt->exact v))))))
|
||||
(cons "truncatedTo" (lambda (x u) (zdt-with-ldt x (ldt-combine (ldt-date (zdt-ldt x)) (lt-truncate (ldt-time (zdt-ldt x)) u)))))
|
||||
(cons "withZoneSameInstant" (lambda (x zone) (zoned-of-instant-ms (zdt->ms x) zone)))
|
||||
(cons "withZoneSameInstant" (lambda (x zone) (zoned-of-instant-nanos (zdt->nanos x) zone)))
|
||||
(cons "withZoneSameLocal" (lambda (x zone) (zoned-of-ldt (zdt-ldt x) zone)))
|
||||
(cons "withFixedOffsetZone" (lambda (x) (jt-zoned-dt (zdt-epoch-day x) (zdt-nano-of-day x) (zdt-offset x) (jt-zone-id (zo-id (zdt-offset x)) (zdt-offset x)))))
|
||||
(cons "plus" (case-lambda ((x a) (zdt-plus-amount x a 1)) ((x n u) (zdt-with-ldt x (temporal-plus-unit (zdt-ldt x) (jt->exact n) (arg-unit-name u))))))
|
||||
|
|
@ -1747,14 +1883,14 @@
|
|||
(cons "getSecond" (lambda (x) (lt-second (odt-ldt x))))
|
||||
(cons "getNano" (lambda (x) (lt-nano (odt-ldt x))))
|
||||
(cons "getOffset" (lambda (x) (jt-zone-offset (odt-offset x))))
|
||||
(cons "toInstant" (lambda (x) (mk-instant (odt->ms x))))
|
||||
(cons "toInstant" (lambda (x) (mk-instant-nanos (odt->nanos x))))
|
||||
(cons "toLocalDate" (lambda (x) (jt-local-date (odt-epoch-day x))))
|
||||
(cons "toLocalTime" (lambda (x) (jt-local-time (odt-nano-of-day x))))
|
||||
(cons "toLocalDateTime" (lambda (x) (odt-ldt x)))
|
||||
(cons "toOffsetTime" (lambda (x) (jt-offset-time (odt-nano-of-day x) (odt-offset x))))
|
||||
(cons "toZonedDateTime" (lambda (x) (jt-zoned-dt (odt-epoch-day x) (odt-nano-of-day x) (odt-offset x) (jt-zone-id (zo-id (odt-offset x)) (odt-offset x)))))
|
||||
(cons "toEpochSecond" (lambda (x) (jt-floor-div (odt->ms x) 1000)))
|
||||
(cons "atZoneSameInstant" (lambda (x zone) (zoned-of-instant-ms (odt->ms x) zone)))
|
||||
(cons "atZoneSameInstant" (lambda (x zone) (zoned-of-instant-nanos (odt->nanos x) zone)))
|
||||
(cons "atZoneSimilarLocal" (lambda (x zone) (zoned-of-ldt (odt-ldt x) zone)))
|
||||
(cons "withOffsetSameInstant" (lambda (x off) (offset-of-instant-ms (odt->ms x) off)))
|
||||
(cons "withOffsetSameLocal" (lambda (x off) (offset-of-ldt (odt-ldt x) off)))
|
||||
|
|
@ -1922,9 +2058,34 @@
|
|||
((jt-offset-time? v) (let ((t (jt-local-time (ot-nod v)))) (vector 1970 1 1 (lt-hour t) (lt-minute t) (lt-second t) (lt-nano t) 4 (ot-offset v) #f)))
|
||||
((jt-instant? v) #f) ; instants render via format-ms (UTC)
|
||||
(else #f)))
|
||||
;; Locale month/day names. Only the locales tick exercises (en, fr) are tabled;
|
||||
;; an unknown locale falls back to English. French abbreviations follow CLDR/
|
||||
;; java.time (most carry a trailing period; "mars"/"mai"/"juin"/"août" don't).
|
||||
(define fr-month-full
|
||||
(vector "janvier" "février" "mars" "avril" "mai" "juin"
|
||||
"juillet" "août" "septembre" "octobre" "novembre" "décembre"))
|
||||
(define fr-month-abbr
|
||||
(vector "janv." "févr." "mars" "avr." "mai" "juin"
|
||||
"juil." "août" "sept." "oct." "nov." "déc."))
|
||||
(define fr-day-full ; indexed by day-of-week 0=Sunday
|
||||
(vector "dimanche" "lundi" "mardi" "mercredi" "jeudi" "vendredi" "samedi"))
|
||||
(define fr-day-abbr
|
||||
(vector "dim." "lun." "mar." "mer." "jeu." "ven." "sam."))
|
||||
(define (locale-fr? loc) (and (>= (string-length loc) 2) (string=? (substring loc 0 2) "fr")))
|
||||
;; month display name for a 1-based month under a locale; full? picks MMMM over MMM.
|
||||
(define (locale-month-name loc mo full?)
|
||||
(if (locale-fr? loc)
|
||||
(vector-ref (if full? fr-month-full fr-month-abbr) (- mo 1))
|
||||
(if full? (vector-ref month-names (- mo 1)) (substring (vector-ref month-names (- mo 1)) 0 3))))
|
||||
(define (locale-day-name loc dow full?)
|
||||
(if (locale-fr? loc)
|
||||
(vector-ref (if full? fr-day-full fr-day-abbr) dow)
|
||||
(if full? (vector-ref day-names dow) (substring (vector-ref day-names dow) 0 3))))
|
||||
|
||||
;; the pattern engine for java.time values (extends inst-time.ss's format-ms letters
|
||||
;; with fractional S and real X/x/Z/z from the value's own offset/zone).
|
||||
(define (jt-format-pattern pattern v)
|
||||
(define (jt-format-pattern pattern v . loc)
|
||||
(define locale (if (null? loc) "en" (car loc)))
|
||||
(let ((parts (jt-value-format-parts v)))
|
||||
(if (not parts)
|
||||
(format-ms pattern (ms-of v)) ; instant: UTC engine
|
||||
|
|
@ -1955,10 +2116,10 @@
|
|||
((or (char=? c #\y) (char=? c #\Y)) (display (if (>= k 4) (pad4 y) (pad2 (modulo y 100))) out) (loop (+ i k)))
|
||||
((char=? c #\M)
|
||||
(display (cond ((= k 1) (number->string mo)) ((= k 2) (pad2 mo))
|
||||
((= k 3) (substring (vector-ref month-names (- mo 1)) 0 3))
|
||||
(else (vector-ref month-names (- mo 1)))) out) (loop (+ i k)))
|
||||
((= k 3) (locale-month-name locale mo #f))
|
||||
(else (locale-month-name locale mo #t))) out) (loop (+ i k)))
|
||||
((char=? c #\d) (display (if (= k 1) (number->string d) (pad2 d)) out) (loop (+ i k)))
|
||||
((char=? c #\E) (display (if (>= k 4) (vector-ref day-names dow) (substring (vector-ref day-names dow) 0 3)) out) (loop (+ i k)))
|
||||
((char=? c #\E) (display (locale-day-name locale dow (>= k 4)) out) (loop (+ i k)))
|
||||
((char=? c #\H) (display (if (= k 1) (number->string hh) (pad2 hh)) out) (loop (+ i k)))
|
||||
((char=? c #\h) (let ((h12 (let ((h (modulo hh 12))) (if (= h 0) 12 h)))) (display (if (= k 1) (number->string h12) (pad2 h12)) out)) (loop (+ i k)))
|
||||
((char=? c #\m) (display (if (= k 1) (number->string mi) (pad2 mi)) out) (loop (+ i k)))
|
||||
|
|
@ -1977,7 +2138,7 @@
|
|||
;; .format on a dt-formatter applied to a java.time value. The pattern comes from the
|
||||
;; formatter; ISO_* constants carry a literal pattern that round-trips through here.
|
||||
(define (fmt-format fmt v)
|
||||
(cond ((and (jhost? fmt) (string=? (jhost-tag fmt) "dt-formatter")) (jt-format-pattern (fmt-pat fmt) v))
|
||||
(cond ((and (jhost? fmt) (string=? (jhost-tag fmt) "dt-formatter")) (jt-format-pattern (fmt-pat fmt) v (fmt-locale fmt)))
|
||||
((string? fmt) (jt-format-pattern fmt v))
|
||||
(else (jt-value->iso v))))
|
||||
(define (jt-value->iso v)
|
||||
|
|
@ -1997,9 +2158,9 @@
|
|||
;; extend the dt-formatter method table: .format routes java.time values through the
|
||||
;; richer engine; .parse picks the value type from the parsed fields.
|
||||
(register-host-methods! "dt-formatter"
|
||||
(list (cons "format" (lambda (self d) (jt-format-pattern (fmt-pat self) d)))
|
||||
(list (cons "format" (lambda (self d) (jt-format-pattern (fmt-pat self) d (fmt-locale self))))
|
||||
(cons "getZone" (lambda (self) (jt-zone-id "Z" 0)))
|
||||
(cons "getLocale" (lambda (self) (make-jhost "locale" (vector "en-US"))))
|
||||
(cons "getLocale" (lambda (self) (make-jhost "locale" (vector (fmt-locale self)))))
|
||||
(cons "toString" (lambda (self) (fmt-pat self)))))
|
||||
|
||||
;; DateTimeFormatter ISO constants (richer engine; the pattern strings drive parse +
|
||||
|
|
@ -2058,8 +2219,15 @@
|
|||
(register-hash-arm! jt-zoned-dt? (lambda (x) (jolt-hash (zdt->ms x))))
|
||||
(register-hash-arm! jt-offset-dt? (lambda (x) (jolt-hash (odt->ms x))))
|
||||
(register-hash-arm! jt-offset-time? (lambda (x) (jolt-hash (ot-nod x))))
|
||||
;; ZonedDateTime equality is local-date-time + offset + zone id (java.time
|
||||
;; ZonedDateTime.equals). Compare fields, not the raw state: the state holds a
|
||||
;; nested zone-id record that Chez equal? compares by identity, not contents.
|
||||
(register-eq-arm! (lambda (a b) (or (jt-zoned-dt? a) (jt-zoned-dt? b)))
|
||||
(lambda (a b) (and (jt-zoned-dt? a) (jt-zoned-dt? b) (equal? (jhost-state a) (jhost-state b)))))
|
||||
(lambda (a b) (and (jt-zoned-dt? a) (jt-zoned-dt? b)
|
||||
(= (zdt-epoch-day a) (zdt-epoch-day b))
|
||||
(= (zdt-nano-of-day a) (zdt-nano-of-day b))
|
||||
(= (zdt-offset a) (zdt-offset b))
|
||||
(string=? (zid-id (zdt-zone a)) (zid-id (zdt-zone b))))))
|
||||
(register-eq-arm! (lambda (a b) (or (jt-offset-dt? a) (jt-offset-dt? b)))
|
||||
(lambda (a b) (and (jt-offset-dt? a) (jt-offset-dt? b) (equal? (jhost-state a) (jhost-state b)))))
|
||||
(register-eq-arm! (lambda (a b) (or (jt-offset-time? a) (jt-offset-time? b)))
|
||||
|
|
|
|||
|
|
@ -17,6 +17,92 @@
|
|||
(define (set-source-roots! roots) (set! source-roots roots))
|
||||
(define (get-source-roots) source-roots)
|
||||
|
||||
;; --- data readers (#tag literals) -------------------------------------------
|
||||
;; A project's data_readers.{clj,cljc} at a source root maps a tag symbol to a
|
||||
;; qualified reader fn (e.g. {time/date time-literals.data-readers/date}). We
|
||||
;; merge those into clojure.core/*data-readers* and require each reader's
|
||||
;; namespace, then while loading source rewrite a registered #tag form into a
|
||||
;; call (reader-fn 'inner-form) so the value is built at runtime. #inst/#uuid and
|
||||
;; #"regex" stay built-in (the analyzer lowers them); only tags present in
|
||||
;; *data-readers* are rewritten. data-readers-active gates the per-form walk so
|
||||
;; projects without data readers (the common case) pay nothing.
|
||||
(define data-readers-active #f)
|
||||
(define (data-readers-table) (var-deref "clojure.core" "*data-readers*"))
|
||||
;; tag keyword (:#time/date) -> its registered reader symbol, or #f.
|
||||
(define (data-reader-symbol tag)
|
||||
(and (keyword? tag)
|
||||
(let ((nm (keyword-t-name tag)))
|
||||
(and (> (string-length nm) 0) (char=? (string-ref nm 0) #\#)
|
||||
(let* ((bare (substring nm 1 (string-length nm)))
|
||||
(slash (let loop ((i 0))
|
||||
(cond ((>= i (string-length bare)) #f)
|
||||
((char=? (string-ref bare i) #\/) i)
|
||||
(else (loop (+ i 1))))))
|
||||
(sym (if slash
|
||||
(jolt-symbol (substring bare 0 slash) (substring bare (+ slash 1) (string-length bare)))
|
||||
(jolt-symbol #f bare)))
|
||||
(t (data-readers-table))
|
||||
(v (and (pmap? t) (jolt-get t sym))))
|
||||
(and v (not (jolt-nil? v)) v))))))
|
||||
;; change-tracking walk: rewrite registered #tag forms, keep everything else
|
||||
;; (and its identity/metadata) intact. Mirrors reader.ss rdr-form->data but keeps
|
||||
;; set FORMS for the compiler spine instead of building real sets.
|
||||
(define (ldr-conv-each xs)
|
||||
(let loop ((xs xs) (acc '()) (changed #f))
|
||||
(if (null? xs) (values (reverse acc) changed)
|
||||
(let ((c (ldr-apply-readers (car xs))))
|
||||
(loop (cdr xs) (cons c acc) (or changed (not (eq? c (car xs)))))))))
|
||||
(define (ldr-apply-readers x)
|
||||
(cond
|
||||
((and (pmap? x) (eq? (jolt-get x rdr-kw-jolt-type) rdr-kw-jolt-tagged))
|
||||
(let ((rdr (data-reader-symbol (jolt-get x rdr-kw-tag)))
|
||||
(inner (ldr-apply-readers (jolt-get x rdr-kw-form))))
|
||||
(cond (rdr (jolt-list rdr (jolt-list (jolt-symbol #f "quote") inner)))
|
||||
((eq? inner (jolt-get x rdr-kw-form)) x)
|
||||
(else (rdr-make-tagged (jolt-get x rdr-kw-tag) inner)))))
|
||||
((rdr-set-form? x)
|
||||
(let-values (((items changed) (ldr-conv-each (seq->list (jolt-get x rdr-kw-value)))))
|
||||
(if changed (rdr-carry-meta x (rdr-make-set items)) x)))
|
||||
((pvec? x)
|
||||
(let-values (((items changed) (ldr-conv-each (vector->list (pvec-v x)))))
|
||||
(if changed (rdr-carry-meta x (apply jolt-vector items)) x)))
|
||||
((pmap? x)
|
||||
(let ((order (hashtable-ref rdr-map-order x #f)))
|
||||
(if order
|
||||
(let-values (((kvs changed) (ldr-conv-each order)))
|
||||
(if changed (rdr-carry-meta x (rdr-make-map kvs)) x))
|
||||
(let-values (((kvs changed) (ldr-conv-each (pmap-fold x (lambda (k v a) (cons k (cons v a))) '()))))
|
||||
(if changed (rdr-carry-meta x (apply jolt-hash-map kvs)) x)))))
|
||||
((cseq? x)
|
||||
(let-values (((items changed) (ldr-conv-each (seq->list x))))
|
||||
(if changed (rdr-carry-meta x (apply jolt-list items)) x)))
|
||||
(else x)))
|
||||
|
||||
;; read+merge one data_readers file: a literal {tag-sym reader-sym …} map.
|
||||
(define (merge-data-readers-file path)
|
||||
(let* ((src (read-file-string path)))
|
||||
(let-values (((m j) (rdr-read-form src 0 (string-length src))))
|
||||
(when (and (not (rdr-eof? m)) (pmap? m))
|
||||
(let ((cur (data-readers-table)))
|
||||
(def-var! "clojure.core" "*data-readers*"
|
||||
(apply jolt-assoc (if (pmap? cur) cur empty-pmap)
|
||||
(pmap-fold m (lambda (k v a) (cons k (cons v a))) '()))))
|
||||
(set! data-readers-active #t)
|
||||
;; eagerly load each reader fn's namespace so the rewritten call resolves.
|
||||
(pmap-fold m (lambda (k v a)
|
||||
(when (and (symbol-t? v) (symbol-t-ns v) (not (jolt-nil? (symbol-t-ns v))))
|
||||
(guard (e (#t #f)) (load-namespace (symbol-t-ns v))))
|
||||
a)
|
||||
#f)))))
|
||||
(define (load-data-readers!)
|
||||
(for-each
|
||||
(lambda (root)
|
||||
(let ((clj (string-append root "/data_readers.clj"))
|
||||
(cljc (string-append root "/data_readers.cljc")))
|
||||
(cond ((file-exists? clj) (merge-data-readers-file clj))
|
||||
((file-exists? cljc) (merge-data-readers-file cljc)))))
|
||||
source-roots))
|
||||
|
||||
;; --- namespace -> file path -------------------------------------------------
|
||||
;; "app.commonmark-test" -> "app/commonmark_test": split on '.', munge '-'->'_'
|
||||
;; per segment, join with '/'. Matches Clojure's ns->file munging.
|
||||
|
|
@ -91,7 +177,8 @@
|
|||
(when (getenv "JOLT_TRACE_LOAD")
|
||||
(display " [load-form] " (current-error-port))
|
||||
(display (jolt-pr-str form) (current-error-port)) (newline (current-error-port)))
|
||||
(jolt-compile-eval-form form (chez-current-ns)))
|
||||
(jolt-compile-eval-form (if data-readers-active (ldr-apply-readers form) form)
|
||||
(chez-current-ns)))
|
||||
(loop j)))))))
|
||||
|
||||
;; load-namespace: load `name`'s source once. Marked loaded BEFORE eval so a
|
||||
|
|
@ -205,7 +292,7 @@
|
|||
|
||||
;; Expose source-root control + ns loading to Clojure (jolt.main / jolt.deps).
|
||||
(def-var! "jolt.host" "set-source-roots!"
|
||||
(lambda (roots) (set-source-roots! (seq->list roots)) jolt-nil))
|
||||
(lambda (roots) (set-source-roots! (seq->list roots)) (load-data-readers!) jolt-nil))
|
||||
(def-var! "jolt.host" "source-roots" (lambda () (list->cseq source-roots)))
|
||||
(def-var! "jolt.host" "load-namespace" (lambda (n) (load-namespace n) jolt-nil))
|
||||
(def-var! "jolt.host" "file-exists?" (lambda (p) (if (file-exists? p) #t #f)))
|
||||
|
|
|
|||
|
|
@ -560,8 +560,42 @@
|
|||
(define (rdr-carry-meta src dst)
|
||||
(let ((m (jolt-meta src))) (if (jolt-nil? m) dst (jolt-with-meta dst m))))
|
||||
|
||||
;; tag keyword (:#time/date) -> its *data-readers* reader fn, or #f. The fn's
|
||||
;; namespace must already be loaded (the loader requires them when a project's
|
||||
;; data_readers.{clj,cljc} registers a tag).
|
||||
(define (rdr-data-reader-fn tag)
|
||||
(and (keyword? tag)
|
||||
(let ((nm (keyword-t-name tag)))
|
||||
(and (> (string-length nm) 0) (char=? (string-ref nm 0) #\#)
|
||||
(let* ((bare (substring nm 1 (string-length nm)))
|
||||
(slash (let loop ((i 0))
|
||||
(cond ((>= i (string-length bare)) #f)
|
||||
((char=? (string-ref bare i) #\/) i)
|
||||
(else (loop (+ i 1))))))
|
||||
(sym (if slash
|
||||
(jolt-symbol (substring bare 0 slash) (substring bare (+ slash 1) (string-length bare)))
|
||||
(jolt-symbol #f bare)))
|
||||
(dr (var-deref "clojure.core" "*data-readers*"))
|
||||
(v (and (pmap? dr) (jolt-get dr sym))))
|
||||
(and v (not (jolt-nil? v)) (symbol-t? v) (not (jolt-nil? (symbol-t-ns v)))
|
||||
(guard (e (#t #f))
|
||||
(let ((fn (var-deref (symbol-t-ns v) (symbol-t-name v))))
|
||||
(and (procedure? fn) fn)))))))))
|
||||
;; read-string / read data seam: construct the value for a #tag literal. #inst,
|
||||
;; #uuid and #"regex" are built in; any other tag is applied from *data-readers*.
|
||||
;; An unregistered tag stays a tagged FORM (lenient — clojure.edn raises instead).
|
||||
(define (rdr-construct-tag tag inner)
|
||||
(cond
|
||||
((eq? tag (keyword #f "#inst")) (jolt-inst-from-string inner))
|
||||
((eq? tag (keyword #f "#uuid")) (jolt-uuid-from-string inner))
|
||||
((eq? tag (keyword #f "regex")) (jolt-re-pattern inner))
|
||||
(else (let ((fn (rdr-data-reader-fn tag)))
|
||||
(if fn (jolt-invoke fn inner) (rdr-make-tagged tag inner))))))
|
||||
|
||||
(define (rdr-form->data x)
|
||||
(cond
|
||||
((and (pmap? x) (eq? (jolt-get x rdr-kw-jolt-type) rdr-kw-jolt-tagged))
|
||||
(rdr-construct-tag (jolt-get x rdr-kw-tag) (rdr-form->data (jolt-get x rdr-kw-form))))
|
||||
((rdr-set-form? x)
|
||||
(let ((items (jolt-get x rdr-kw-value)))
|
||||
(rdr-carry-meta x
|
||||
|
|
|
|||
|
|
@ -128,11 +128,11 @@
|
|||
((keyword? obj) '("Keyword" "Named" "Object"))
|
||||
((jolt-symbol? obj) '("Symbol" "Named" "Object"))
|
||||
((pvec? obj) '("PersistentVector" "APersistentVector" "IPersistentVector" "IPersistentCollection"
|
||||
"List" "java.util.List" "Sequential" "Collection" "Object"))
|
||||
"List" "java.util.List" "Sequential" "Collection" "Iterable" "java.lang.Iterable" "Object"))
|
||||
((pmap? obj) '("PersistentArrayMap" "APersistentMap" "IPersistentMap" "Associative"
|
||||
"Map" "java.util.Map" "Object"))
|
||||
((pset? obj) '("PersistentHashSet" "APersistentSet" "IPersistentSet" "Set" "java.util.Set" "Collection" "Object"))
|
||||
((or (cseq? obj) (empty-list-t? obj)) '("ASeq" "ISeq" "IPersistentCollection" "Sequential" "Collection" "Object"))
|
||||
"Map" "java.util.Map" "Iterable" "java.lang.Iterable" "Object"))
|
||||
((pset? obj) '("PersistentHashSet" "APersistentSet" "IPersistentSet" "Set" "java.util.Set" "Collection" "Iterable" "java.lang.Iterable" "Object"))
|
||||
((or (cseq? obj) (empty-list-t? obj)) '("ASeq" "ISeq" "IPersistentCollection" "Sequential" "Collection" "Iterable" "java.lang.Iterable" "Object"))
|
||||
;; java.net.URI jhost — extend-protocol java.net.URI (hiccup ToURI/ToStr).
|
||||
((and (jhost? obj) (string=? (jhost-tag obj) "uri")) '("URI" "java.net.URI" "Object"))
|
||||
;; host value types a library may extend a protocol to by class (data.json
|
||||
|
|
@ -211,7 +211,7 @@
|
|||
"PersistentHashSet" "APersistentSet" "IPersistentSet"
|
||||
"ASeq" "ISeq" "IPersistentCollection" "Associative" "Sequential"
|
||||
"Map" "java.util.Map" "List" "java.util.List" "Set" "java.util.Set"
|
||||
"Collection" "java.util.Collection"
|
||||
"Collection" "java.util.Collection" "Iterable" "java.lang.Iterable"
|
||||
"UUID" "BigDecimal" "Date" "Timestamp" "Instant" "java.sql.Date"
|
||||
;; java.time value types (extend-protocol Duration / ZonedDateTime / …)
|
||||
"Duration" "Period" "LocalDate" "LocalTime" "LocalDateTime"
|
||||
|
|
|
|||
|
|
@ -146,6 +146,12 @@
|
|||
((keyword? f) (apply jolt-get (car args) f (cdr args))) ; (:k m [d]) -> (get m :k [d])
|
||||
((jolt-coll? f) (apply jolt-get f args)) ; (coll k [d]) -> (get coll k [d])
|
||||
((jolt-transient? f) (apply jolt-get f args)) ; a transient vec/map/set is callable on the JVM
|
||||
;; a record/reify implementing clojure.lang.IFn is callable: dispatch to its
|
||||
;; inline `invoke` method with the value itself as the leading `this`.
|
||||
((and (jrec? f) (find-method-any-protocol (jrec-tag f) "invoke"))
|
||||
=> (lambda (m) (apply jolt-invoke m f args)))
|
||||
((and (reified-methods f) (hashtable-ref (reified-methods f) "invoke" #f))
|
||||
=> (lambda (m) (apply jolt-invoke m f args)))
|
||||
(else (error 'invoke "not a fn" f))))
|
||||
|
||||
;; ============================================================================
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue