java.time Phase 2: Duration/Period, enums, ChronoUnit/Field machinery
Duration (ISO PT.. toString, between, full arithmetic), Period (between with borrow, P.. toString, normalized), full Month/DayOfWeek enums (named constants, print as their name — fixes the Phase-1 raw-jhost print), Year, YearMonth (2020-02 toString, leap, atDay/atEndOfMonth), ChronoUnit (between/getDuration) and ChronoField. The temporal machinery on the Phase-1 types now works with ChronoUnit/ChronoField: (.plus t n DAYS), (.until t1 t2 unit), (.get/.getLong t field), (.with t field v), (.isSupported ..), (.truncatedTo ..). Analyzer: (. Class method args) with a class target lowers to a static call (Class/method args) instead of mis-dispatching as an instance call on the arg — matches JVM; needed by cljc.java-time.year. Seed re-minted; selfhost holds. The Phase-2 cljc.java-time namespaces load; tick.core advances to a Phase-3 zone gap. 10 corpus rows certified vs JVM. make test + shakesmoke green, 0 new divergences, data.json stays 138/139.
This commit is contained in:
Yogthos
parent
c0561a8d14
commit
e3c14e656c
5 changed files with 773 additions and 17 deletions
|
|
@ -453,17 +453,707 @@
|
|||
(cons "toString" (lambda (x) (iso-instant-str (inst-ms x))))))
|
||||
|
||||
;; --- Month / DayOfWeek enums (returned by getMonth / getDayOfWeek) -----------
|
||||
;; minimal: name / getValue / toString, plus the static value fields cljc.java-time
|
||||
;; might def at load (java.time.Month/JANUARY etc. — not needed by the four core nses
|
||||
;; but harmless to provide).
|
||||
(define (jt-month n) (make-jhost "month-enum" (vector n)))
|
||||
(define (jt-dow n) (make-jhost "dow-enum" (vector n)))
|
||||
(define (month-val e) (vector-ref (jhost-state e) 0))
|
||||
(define (dow-val e) (vector-ref (jhost-state e) 0))
|
||||
(define (month-name n) (vector-ref jt-month-names (- n 1)))
|
||||
(define (dow-name n) (vector-ref jt-day-names (- n 1)))
|
||||
;; quarter starts: Jan/Apr/Jul/Oct.
|
||||
(define (month-quarter-start m) (+ 1 (* 3 (quotient (- m 1) 3))))
|
||||
;; day-of-year of the first day of month m (non-leap base; +1 from March on a leap year).
|
||||
(define (month-first-day-of-year m leap)
|
||||
(let ((cum (vector 0 0 31 59 90 120 151 181 212 243 273 304 334)))
|
||||
(+ 1 (vector-ref cum m) (if (and leap (> m 2)) 1 0))))
|
||||
|
||||
(register-host-methods! "month-enum"
|
||||
(list (cons "getValue" (lambda (e) (vector-ref (jhost-state e) 0)))
|
||||
(cons "name" (lambda (e) (vector-ref jt-month-names (- (vector-ref (jhost-state e) 0) 1))))
|
||||
(cons "toString" (lambda (e) (vector-ref jt-month-names (- (vector-ref (jhost-state e) 0) 1))))))
|
||||
(list (cons "getValue" (lambda (e) (month-val e)))
|
||||
(cons "ordinal" (lambda (e) (- (month-val e) 1)))
|
||||
(cons "name" (lambda (e) (month-name (month-val e))))
|
||||
(cons "toString" (lambda (e) (month-name (month-val e))))
|
||||
(cons "getDisplayName" (lambda (e . _) (month-name (month-val e))))
|
||||
(cons "plus" (lambda (e n) (jt-month (+ 1 (jt-floor-mod (+ (- (month-val e) 1) (jt->exact n)) 12)))))
|
||||
(cons "minus" (lambda (e n) (jt-month (+ 1 (jt-floor-mod (- (- (month-val e) 1) (jt->exact n)) 12)))))
|
||||
(cons "length" (lambda (e leap) (jt-len-of-month (if (jolt-truthy? leap) 4 1) (month-val e))))
|
||||
(cons "minLength" (lambda (e) (if (= (month-val e) 2) 28 (jt-len-of-month 1 (month-val e)))))
|
||||
(cons "maxLength" (lambda (e) (if (= (month-val e) 2) 29 (jt-len-of-month 1 (month-val e)))))
|
||||
(cons "firstMonthOfQuarter" (lambda (e) (jt-month (month-quarter-start (month-val e)))))
|
||||
(cons "firstDayOfYear" (lambda (e leap) (month-first-day-of-year (month-val e) (jolt-truthy? leap))))
|
||||
(cons "compareTo" (lambda (e o) (- (month-val e) (month-val o))))
|
||||
(cons "equals" (lambda (e o) (and (jhost? o) (string=? (jhost-tag o) "month-enum") (= (month-val e) (month-val o)))))
|
||||
(cons "hashCode" (lambda (e) (month-val e)))))
|
||||
(register-host-methods! "dow-enum"
|
||||
(list (cons "getValue" (lambda (e) (vector-ref (jhost-state e) 0)))
|
||||
(cons "name" (lambda (e) (vector-ref jt-day-names (- (vector-ref (jhost-state e) 0) 1))))
|
||||
(cons "toString" (lambda (e) (vector-ref jt-day-names (- (vector-ref (jhost-state e) 0) 1))))))
|
||||
(list (cons "getValue" (lambda (e) (dow-val e)))
|
||||
(cons "ordinal" (lambda (e) (- (dow-val e) 1)))
|
||||
(cons "name" (lambda (e) (dow-name (dow-val e))))
|
||||
(cons "toString" (lambda (e) (dow-name (dow-val e))))
|
||||
(cons "getDisplayName" (lambda (e . _) (dow-name (dow-val e))))
|
||||
(cons "plus" (lambda (e n) (jt-dow (+ 1 (jt-floor-mod (+ (- (dow-val e) 1) (jt->exact n)) 7)))))
|
||||
(cons "minus" (lambda (e n) (jt-dow (+ 1 (jt-floor-mod (- (- (dow-val e) 1) (jt->exact n)) 7)))))
|
||||
(cons "compareTo" (lambda (e o) (- (dow-val e) (dow-val o))))
|
||||
(cons "equals" (lambda (e o) (and (jhost? o) (string=? (jhost-tag o) "dow-enum") (= (dow-val e) (dow-val o)))))
|
||||
(cons "hashCode" (lambda (e) (dow-val e)))))
|
||||
|
||||
(define (month-from-temporal t)
|
||||
(cond ((and (jhost? t) (string=? (jhost-tag t) "month-enum")) t)
|
||||
((jt-date? t) (jt-month (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) (lambda (y m d) m))))
|
||||
((jt-dt? t) (jt-month (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day t))) (lambda (y m d) m))))
|
||||
(else (error #f "Month/from: unsupported"))))
|
||||
(register-class-statics! "Month"
|
||||
(append
|
||||
(list (cons "of" (lambda (n) (jt-month (jt->exact n))))
|
||||
(cons "valueOf" (lambda (s) (let ((nm (jt-str s)))
|
||||
(let loop ((i 0)) (cond ((= i 12) (error #f (string-append "No enum constant Month." nm)))
|
||||
((string=? (vector-ref jt-month-names i) nm) (jt-month (+ i 1)))
|
||||
(else (loop (+ i 1))))))))
|
||||
(cons "from" (lambda (t) (month-from-temporal t)))
|
||||
(cons "values" (lambda () (make-pvec (list->vector (map jt-month '(1 2 3 4 5 6 7 8 9 10 11 12)))))))
|
||||
(map (lambda (i) (cons (vector-ref jt-month-names (- i 1)) (jt-month i))) '(1 2 3 4 5 6 7 8 9 10 11 12))))
|
||||
(define (dow-from-temporal t)
|
||||
(cond ((and (jhost? t) (string=? (jhost-tag t) "dow-enum")) t)
|
||||
((jt-date? t) (jt-dow (ld-dow (ld-epoch-day t))))
|
||||
((jt-dt? t) (jt-dow (ld-dow (ldt-epoch-day t))))
|
||||
(else (error #f "DayOfWeek/from: unsupported"))))
|
||||
(register-class-statics! "DayOfWeek"
|
||||
(append
|
||||
(list (cons "of" (lambda (n) (jt-dow (jt->exact n))))
|
||||
(cons "valueOf" (lambda (s) (let ((nm (jt-str s)))
|
||||
(let loop ((i 0)) (cond ((= i 7) (error #f (string-append "No enum constant DayOfWeek." nm)))
|
||||
((string=? (vector-ref jt-day-names i) nm) (jt-dow (+ i 1)))
|
||||
(else (loop (+ i 1))))))))
|
||||
(cons "from" (lambda (t) (dow-from-temporal t)))
|
||||
(cons "values" (lambda () (make-pvec (list->vector (map jt-dow '(1 2 3 4 5 6 7)))))))
|
||||
(map (lambda (i) (cons (vector-ref jt-day-names (- i 1)) (jt-dow i))) '(1 2 3 4 5 6 7))))
|
||||
|
||||
;; --- Duration: (vector seconds nanos), nanos in [0, 1e9) ----------------------
|
||||
(define (dur-normalize secs nanos)
|
||||
(let* ((carry (jt-floor-div nanos nanos-per-sec))
|
||||
(n (jt-floor-mod nanos nanos-per-sec)))
|
||||
(make-jhost "duration" (vector (+ secs carry) n))))
|
||||
(define (dur-secs d) (vector-ref (jhost-state d) 0))
|
||||
(define (dur-nanos d) (vector-ref (jhost-state d) 1))
|
||||
(define (dur-total-nanos d) (+ (* (dur-secs d) nanos-per-sec) (dur-nanos d)))
|
||||
(define (dur-of-total-nanos tn) (dur-normalize (jt-floor-div tn nanos-per-sec) (jt-floor-mod tn nanos-per-sec)))
|
||||
(define dur-zero (make-jhost "duration" (vector 0 0)))
|
||||
|
||||
;; ISO-8601: PTnHnMnS. Components come from the normalized (secs,nanos>=0) state;
|
||||
;; each H/M/S field carries its own sign (java.time prints them per-component). The
|
||||
;; seconds field folds in the fractional nanos: a negative second with nanos shows
|
||||
;; e.g. "-0.5" (rem-sec -1 + nanos 5e8 -> -0.5).
|
||||
(define (dur->string d)
|
||||
(let ((secs (dur-secs d)) (nanos (dur-nanos d)))
|
||||
(if (and (= secs 0) (= nanos 0)) "PT0S"
|
||||
(let* ((hours (quotient secs 3600))
|
||||
(mins (quotient (remainder secs 3600) 60))
|
||||
(rem-secs (remainder secs 60))
|
||||
(out (open-output-string)))
|
||||
(display "PT" out)
|
||||
(unless (= hours 0) (display (number->string hours) out) (write-char #\H out))
|
||||
(unless (= mins 0) (display (number->string mins) out) (write-char #\M out))
|
||||
(when (or (not (= rem-secs 0)) (not (= nanos 0)) (and (= hours 0) (= mins 0)))
|
||||
(if (= nanos 0)
|
||||
(display (number->string rem-secs) out)
|
||||
;; whole second + fraction; a negative rem-sec with positive nanos
|
||||
;; rolls toward zero (rem+1) and shows fraction as 1e9-nanos.
|
||||
(let* ((neg (< rem-secs 0))
|
||||
(whole (if neg (+ rem-secs 1) rem-secs))
|
||||
(frac (if neg (- nanos-per-sec nanos) nanos)))
|
||||
(when (and neg (= whole 0)) (write-char #\- out))
|
||||
(display (number->string whole) out)
|
||||
(write-char #\. out)
|
||||
(display (dur-frac-digits frac) out)))
|
||||
(write-char #\S out))
|
||||
(get-output-string out)))))
|
||||
;; nanos -> a 9-digit fraction with all trailing zeros stripped (Duration shows the
|
||||
;; minimal fraction, e.g. .5, unlike LocalTime which pads to 3/6/9).
|
||||
(define (dur-frac-digits nano)
|
||||
(let ((s9 (let ((s (number->string nano))) (string-append (make-string (max 0 (- 9 (string-length s))) #\0) s))))
|
||||
(let loop ((i 9)) (cond ((<= i 1) (substring s9 0 1))
|
||||
((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
|
||||
(cond ((jt-instant? t) (* (inst-ms t) 1000000))
|
||||
((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))
|
||||
(else (error #f "Duration/between: unsupported temporal"))))
|
||||
(register-class-statics! "Duration"
|
||||
(list (cons "ZERO" dur-zero)
|
||||
(cons "of" (lambda (n unit) (dur-of-total-nanos (* (jt->exact n) (chrono-unit-nanos unit)))))
|
||||
(cons "ofDays" (lambda (n) (dur-normalize (* (jt->exact n) 86400) 0)))
|
||||
(cons "ofHours" (lambda (n) (dur-normalize (* (jt->exact n) 3600) 0)))
|
||||
(cons "ofMinutes" (lambda (n) (dur-normalize (* (jt->exact n) 60) 0)))
|
||||
(cons "ofSeconds" (case-lambda
|
||||
((s) (dur-normalize (jt->exact s) 0))
|
||||
((s na) (dur-normalize (jt->exact s) (jt->exact na)))))
|
||||
(cons "ofMillis" (lambda (n) (dur-of-total-nanos (* (jt->exact n) 1000000))))
|
||||
(cons "ofNanos" (lambda (n) (dur-of-total-nanos (jt->exact n))))
|
||||
(cons "between" (lambda (a b) (dur-of-total-nanos (- (dur-temporal-nanos b) (dur-temporal-nanos a)))))
|
||||
(cons "from" (lambda (t) (if (and (jhost? t) (string=? (jhost-tag t) "duration")) t (error #f "Duration/from"))))
|
||||
(cons "parse" (lambda (s) (parse-iso-duration (jt-str s))))))
|
||||
|
||||
(define (dur-plus a b) (dur-of-total-nanos (+ (dur-total-nanos a) (dur-total-nanos b))))
|
||||
(register-host-methods! "duration"
|
||||
(list (cons "getSeconds" (lambda (d) (dur-secs d)))
|
||||
(cons "getNano" (lambda (d) (dur-nanos d)))
|
||||
(cons "toDays" (lambda (d) (quotient (dur-secs d) 86400)))
|
||||
(cons "toHours" (lambda (d) (quotient (dur-secs d) 3600)))
|
||||
(cons "toMinutes" (lambda (d) (quotient (dur-secs d) 60)))
|
||||
(cons "toMillis" (lambda (d) (+ (* (dur-secs d) 1000) (quotient (dur-nanos d) 1000000))))
|
||||
(cons "toNanos" (lambda (d) (dur-total-nanos d)))
|
||||
(cons "plus" (lambda (d o) (cond ((and (jhost? o) (string=? (jhost-tag o) "duration")) (dur-plus d o))
|
||||
(else (error #f "Duration.plus: expected Duration")))))
|
||||
(cons "minus" (lambda (d o) (dur-of-total-nanos (- (dur-total-nanos d) (dur-total-nanos o)))))
|
||||
(cons "plusDays" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) 86400 nanos-per-sec)))))
|
||||
(cons "plusHours" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) 3600 nanos-per-sec)))))
|
||||
(cons "plusMinutes" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) 60 nanos-per-sec)))))
|
||||
(cons "plusSeconds" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) nanos-per-sec)))))
|
||||
(cons "plusMillis" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (* (jt->exact n) 1000000)))))
|
||||
(cons "plusNanos" (lambda (d n) (dur-of-total-nanos (+ (dur-total-nanos d) (jt->exact n)))))
|
||||
(cons "minusDays" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) 86400 nanos-per-sec)))))
|
||||
(cons "minusHours" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) 3600 nanos-per-sec)))))
|
||||
(cons "minusMinutes" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) 60 nanos-per-sec)))))
|
||||
(cons "minusSeconds" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) nanos-per-sec)))))
|
||||
(cons "minusMillis" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (* (jt->exact n) 1000000)))))
|
||||
(cons "minusNanos" (lambda (d n) (dur-of-total-nanos (- (dur-total-nanos d) (jt->exact n)))))
|
||||
(cons "multipliedBy" (lambda (d n) (dur-of-total-nanos (* (dur-total-nanos d) (jt->exact n)))))
|
||||
(cons "dividedBy" (lambda (d n) (dur-of-total-nanos (quotient (dur-total-nanos d) (jt->exact n)))))
|
||||
(cons "negated" (lambda (d) (dur-of-total-nanos (- (dur-total-nanos d)))))
|
||||
(cons "abs" (lambda (d) (dur-of-total-nanos (abs (dur-total-nanos d)))))
|
||||
(cons "withSeconds" (lambda (d s) (dur-normalize (jt->exact s) (dur-nanos d))))
|
||||
(cons "withNanos" (lambda (d na) (dur-normalize (dur-secs d) (jt->exact na))))
|
||||
(cons "isZero" (lambda (d) (and (= (dur-secs d) 0) (= (dur-nanos d) 0))))
|
||||
(cons "isNegative" (lambda (d) (< (dur-total-nanos d) 0)))
|
||||
(cons "compareTo" (lambda (d o) (let ((a (dur-total-nanos d)) (b (dur-total-nanos o)))
|
||||
(cond ((< a b) -1) ((> a b) 1) (else 0)))))
|
||||
(cons "equals" (lambda (d o) (and (jhost? o) (string=? (jhost-tag o) "duration") (= (dur-total-nanos d) (dur-total-nanos o)))))
|
||||
(cons "hashCode" (lambda (d) (jolt-hash (dur-total-nanos d))))
|
||||
;; TemporalAmount: addTo/subtractFrom apply this duration to a temporal.
|
||||
(cons "addTo" (lambda (d t) (temporal-plus-nanos t (dur-total-nanos d))))
|
||||
(cons "subtractFrom" (lambda (d t) (temporal-plus-nanos t (- (dur-total-nanos d)))))
|
||||
(cons "toString" (lambda (d) (dur->string d)))))
|
||||
|
||||
;; "PT…" parse: PnDTnHnMn.nS (we accept the time part; days fold into hours).
|
||||
(define (parse-iso-duration s)
|
||||
(let ((len (string-length s)) (neg #f) (i 0) (total 0))
|
||||
(define (sign-at j) (cond ((>= j len) (values 1 j))
|
||||
((char=? (string-ref s j) #\-) (values -1 (+ j 1)))
|
||||
((char=? (string-ref s j) #\+) (values 1 (+ j 1)))
|
||||
(else (values 1 j))))
|
||||
(when (and (< i len) (char=? (string-ref s i) #\-)) (set! neg #t) (set! i (+ i 1)))
|
||||
(unless (and (< i len) (or (char=? (string-ref s i) #\P) (char=? (string-ref s i) #\p)))
|
||||
(error #f (string-append "could not parse Duration: " s)))
|
||||
(set! i (+ i 1))
|
||||
(let loop ((in-time #f))
|
||||
(when (< i len)
|
||||
(let ((c (string-ref s i)))
|
||||
(cond
|
||||
((or (char=? c #\T) (char=? c #\t)) (set! i (+ i 1)) (loop #t))
|
||||
(else
|
||||
(call-with-values (lambda () (sign-at i))
|
||||
(lambda (sg j)
|
||||
;; read number (with optional fraction)
|
||||
(let num ((k j) (acc 0) (frac 0) (fdigits 0) (in-frac #f) (any #f))
|
||||
(cond
|
||||
((and (< k len) (digit? (string-ref s k)))
|
||||
(if in-frac
|
||||
(num (+ k 1) acc (+ (* frac 10) (- (char->integer (string-ref s k)) 48)) (+ fdigits 1) #t #t)
|
||||
(num (+ k 1) (+ (* acc 10) (- (char->integer (string-ref s k)) 48)) frac fdigits #f #t)))
|
||||
((and (< k len) (char=? (string-ref s k) #\.)) (num (+ k 1) acc frac fdigits #t any))
|
||||
((and any (< k len))
|
||||
(let* ((unit (char-upcase (string-ref s k)))
|
||||
(nanos (* (+ (* acc nanos-per-sec) (* frac (expt 10 (max 0 (- 9 fdigits))))) sg))
|
||||
(mult (cond ((char=? unit #\D) 86400) ((char=? unit #\H) 3600)
|
||||
((char=? unit #\M) (if in-time 60 (error #f "Duration months unsupported")))
|
||||
((char=? unit #\S) 1)
|
||||
(else (error #f (string-append "bad Duration unit: " s))))))
|
||||
(set! total (+ total (* nanos mult)))
|
||||
(set! i (+ k 1))
|
||||
(loop in-time)))
|
||||
(else (error #f (string-append "could not parse Duration: " s))))))))))))
|
||||
(dur-of-total-nanos (if neg (- total) total))))
|
||||
|
||||
;; --- Period: (vector years months days) --------------------------------------
|
||||
(define (jt-period y m d) (make-jhost "period" (vector y m d)))
|
||||
(define (per-years p) (vector-ref (jhost-state p) 0))
|
||||
(define (per-months p) (vector-ref (jhost-state p) 1))
|
||||
(define (per-days p) (vector-ref (jhost-state p) 2))
|
||||
(define per-zero (jt-period 0 0 0))
|
||||
(define (per->string p)
|
||||
(let ((y (per-years p)) (m (per-months p)) (d (per-days p)))
|
||||
(if (and (= y 0) (= m 0) (= d 0)) "P0D"
|
||||
(let ((out (open-output-string)))
|
||||
(write-char #\P out)
|
||||
(unless (= y 0) (display (number->string y) out) (write-char #\Y out))
|
||||
(unless (= m 0) (display (number->string m) out) (write-char #\M out))
|
||||
(unless (= d 0) (display (number->string d) out) (write-char #\D out))
|
||||
(get-output-string out)))))
|
||||
;; Period/between counts whole years/months/days from a to b (java.time semantics).
|
||||
(define (per-between a b)
|
||||
(call-with-values (lambda () (epoch-day->ymd (ld-epoch-day a)))
|
||||
(lambda (y1 m1 d1)
|
||||
(call-with-values (lambda () (epoch-day->ymd (ld-epoch-day b)))
|
||||
(lambda (y2 m2 d2)
|
||||
(let* ((total-months (- (+ (* y2 12) m2) (+ (* y1 12) m1)))
|
||||
(days (- d2 d1)))
|
||||
;; if days go negative, borrow a month (using the prior month length of b)
|
||||
(let-values (((tm dd)
|
||||
(if (and (> total-months 0) (< days 0))
|
||||
(let* ((tm (- total-months 1))
|
||||
(bm (+ (* y1 12) (- m1 1) tm))
|
||||
(by (jt-floor-div bm 12)) (bmo (+ 1 (jt-floor-mod bm 12)))
|
||||
(len (jt-len-of-month by bmo)))
|
||||
(values tm (+ days len)))
|
||||
(if (and (< total-months 0) (> days 0))
|
||||
(values (+ total-months 1) (- days (jt-len-of-month y2 m2)))
|
||||
(values total-months days)))))
|
||||
(jt-period (jt-floor-div tm 12) (jt-floor-mod tm 12) dd))))))))
|
||||
(define (per-normalize p)
|
||||
(let ((tm (+ (* (per-years p) 12) (per-months p))))
|
||||
(jt-period (jt-floor-div tm 12) (jt-floor-mod tm 12) (per-days p))))
|
||||
(register-class-statics! "Period"
|
||||
(list (cons "ZERO" per-zero)
|
||||
(cons "of" (lambda (y m d) (jt-period (jt->exact y) (jt->exact m) (jt->exact d))))
|
||||
(cons "ofYears" (lambda (y) (jt-period (jt->exact y) 0 0)))
|
||||
(cons "ofMonths" (lambda (m) (jt-period 0 (jt->exact m) 0)))
|
||||
(cons "ofWeeks" (lambda (w) (jt-period 0 0 (* 7 (jt->exact w)))))
|
||||
(cons "ofDays" (lambda (d) (jt-period 0 0 (jt->exact d))))
|
||||
(cons "between" (lambda (a b) (per-between a b)))
|
||||
(cons "from" (lambda (t) (if (and (jhost? t) (string=? (jhost-tag t) "period")) t (error #f "Period/from"))))
|
||||
(cons "parse" (lambda (s) (parse-iso-period (jt-str s))))))
|
||||
(register-host-methods! "period"
|
||||
(list (cons "getYears" (lambda (p) (per-years p)))
|
||||
(cons "getMonths" (lambda (p) (per-months p)))
|
||||
(cons "getDays" (lambda (p) (per-days p)))
|
||||
(cons "toTotalMonths" (lambda (p) (+ (* (per-years p) 12) (per-months p))))
|
||||
(cons "plusYears" (lambda (p n) (jt-period (+ (per-years p) (jt->exact n)) (per-months p) (per-days p))))
|
||||
(cons "plusMonths" (lambda (p n) (jt-period (per-years p) (+ (per-months p) (jt->exact n)) (per-days p))))
|
||||
(cons "plusDays" (lambda (p n) (jt-period (per-years p) (per-months p) (+ (per-days p) (jt->exact n)))))
|
||||
(cons "minusYears" (lambda (p n) (jt-period (- (per-years p) (jt->exact n)) (per-months p) (per-days p))))
|
||||
(cons "minusMonths" (lambda (p n) (jt-period (per-years p) (- (per-months p) (jt->exact n)) (per-days p))))
|
||||
(cons "minusDays" (lambda (p n) (jt-period (per-years p) (per-months p) (- (per-days p) (jt->exact n)))))
|
||||
(cons "withYears" (lambda (p n) (jt-period (jt->exact n) (per-months p) (per-days p))))
|
||||
(cons "withMonths" (lambda (p n) (jt-period (per-years p) (jt->exact n) (per-days p))))
|
||||
(cons "withDays" (lambda (p n) (jt-period (per-years p) (per-months p) (jt->exact n))))
|
||||
(cons "plus" (lambda (p o) (jt-period (+ (per-years p) (per-years o)) (+ (per-months p) (per-months o)) (+ (per-days p) (per-days o)))))
|
||||
(cons "minus" (lambda (p o) (jt-period (- (per-years p) (per-years o)) (- (per-months p) (per-months o)) (- (per-days p) (per-days o)))))
|
||||
(cons "multipliedBy" (lambda (p n) (jt-period (* (per-years p) (jt->exact n)) (* (per-months p) (jt->exact n)) (* (per-days p) (jt->exact n)))))
|
||||
(cons "negated" (lambda (p) (jt-period (- (per-years p)) (- (per-months p)) (- (per-days p)))))
|
||||
(cons "normalized" (lambda (p) (per-normalize p)))
|
||||
(cons "isZero" (lambda (p) (and (= (per-years p) 0) (= (per-months p) 0) (= (per-days p) 0))))
|
||||
(cons "isNegative" (lambda (p) (or (< (per-years p) 0) (< (per-months p) 0) (< (per-days p) 0))))
|
||||
(cons "equals" (lambda (p o) (and (jhost? o) (string=? (jhost-tag o) "period")
|
||||
(= (per-years p) (per-years o)) (= (per-months p) (per-months o)) (= (per-days p) (per-days o)))))
|
||||
(cons "hashCode" (lambda (p) (+ (per-years p) (bitwise-arithmetic-shift-left (per-months p) 8) (bitwise-arithmetic-shift-left (per-days p) 16))))
|
||||
;; TemporalAmount: a Period adds its y/m/d to a date-bearing temporal.
|
||||
(cons "addTo" (lambda (p t) (temporal-plus-period t p 1)))
|
||||
(cons "subtractFrom" (lambda (p t) (temporal-plus-period t p -1)))
|
||||
(cons "toString" (lambda (p) (per->string p)))))
|
||||
;; "PnYnMnWnD" -> a Period (weeks fold into days).
|
||||
(define (parse-iso-period s)
|
||||
(let ((len (string-length s)) (sign 1) (i 0) (y 0) (m 0) (d 0))
|
||||
(when (and (< i len) (char=? (string-ref s i) #\-)) (set! sign -1) (set! i (+ i 1)))
|
||||
(unless (and (< i len) (or (char=? (string-ref s i) #\P) (char=? (string-ref s i) #\p)))
|
||||
(error #f (string-append "could not parse Period: " s)))
|
||||
(set! i (+ i 1))
|
||||
(let loop ()
|
||||
(when (< i len)
|
||||
(let ((vsign (cond ((char=? (string-ref s i) #\-) (set! i (+ i 1)) -1)
|
||||
((char=? (string-ref s i) #\+) (set! i (+ i 1)) 1)
|
||||
(else 1))))
|
||||
(let num ((k i) (acc 0) (any #f))
|
||||
(cond
|
||||
((and (< k len) (digit? (string-ref s k))) (num (+ k 1) (+ (* acc 10) (- (char->integer (string-ref s k)) 48)) #t))
|
||||
((and any (< k len))
|
||||
(let ((u (char-upcase (string-ref s k))) (val (* vsign acc)))
|
||||
(cond ((char=? u #\Y) (set! y val)) ((char=? u #\M) (set! m val))
|
||||
((char=? u #\W) (set! d (+ d (* 7 val)))) ((char=? u #\D) (set! d (+ d val)))
|
||||
(else (error #f (string-append "bad Period unit: " s))))
|
||||
(set! i (+ k 1)) (loop)))
|
||||
(else (error #f (string-append "could not parse Period: " s))))))))
|
||||
(jt-period (* sign y) (* sign m) (* sign d))))
|
||||
|
||||
;; --- Year --------------------------------------------------------------------
|
||||
(define (jt-year y) (make-jhost "year" (vector y)))
|
||||
(define (year-val y) (vector-ref (jhost-state y) 0))
|
||||
(define (year-from-temporal t)
|
||||
(cond ((and (jhost? t) (string=? (jhost-tag t) "year")) t)
|
||||
((jt-date? t) (jt-year (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) (lambda (y m d) y))))
|
||||
((jt-dt? t) (jt-year (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day t))) (lambda (y m d) y))))
|
||||
((and (jhost? t) (string=? (jhost-tag t) "year-month")) (jt-year (ym-year t)))
|
||||
(else (error #f "Year/from: unsupported"))))
|
||||
(register-class-statics! "Year"
|
||||
(list (cons "of" (lambda (y) (jt-year (jt->exact y))))
|
||||
(cons "now" (lambda _ (jt-year (call-with-values (lambda () (epoch-day->ymd (jt-floor-div (exact (truncate (now-ms))) 86400000))) (lambda (y m d) y)))))
|
||||
(cons "isLeap" (lambda (y) (jt-leap? (jt->exact y))))
|
||||
(cons "parse" (lambda (s . _) (jt-year (or (string->number (jt-str s)) (error #f "could not parse Year")))))
|
||||
(cons "from" (lambda (t) (year-from-temporal t)))
|
||||
(cons "MIN_VALUE" -999999999)
|
||||
(cons "MAX_VALUE" 999999999)))
|
||||
(register-host-methods! "year"
|
||||
(list (cons "getValue" (lambda (y) (year-val y)))
|
||||
(cons "isLeap" (lambda (y) (jt-leap? (year-val y))))
|
||||
(cons "length" (lambda (y) (if (jt-leap? (year-val y)) 366 365)))
|
||||
(cons "plusYears" (lambda (y n) (jt-year (+ (year-val y) (jt->exact n)))))
|
||||
(cons "minusYears" (lambda (y n) (jt-year (- (year-val y) (jt->exact n)))))
|
||||
(cons "atMonth" (lambda (y m) (jt-year-month (year-val y) (jt->exact m))))
|
||||
(cons "atDay" (lambda (y doy) (jt-local-date (+ (ymd->epoch-day (year-val y) 1 1) (- (jt->exact doy) 1)))))
|
||||
(cons "atMonthDay" (lambda (y md) (error #f "Year.atMonthDay: MonthDay unsupported")))
|
||||
(cons "isBefore" (lambda (y o) (< (year-val y) (year-val o))))
|
||||
(cons "isAfter" (lambda (y o) (> (year-val y) (year-val o))))
|
||||
(cons "isValidMonthDay" (lambda (y md) #f))
|
||||
(cons "compareTo" (lambda (y o) (let ((a (year-val y)) (b (year-val o))) (cond ((< a b) -1) ((> a b) 1) (else 0)))))
|
||||
(cons "equals" (lambda (y o) (and (jhost? o) (string=? (jhost-tag o) "year") (= (year-val y) (year-val o)))))
|
||||
(cons "hashCode" (lambda (y) (year-val y)))
|
||||
(cons "toString" (lambda (y) (number->string (year-val y))))))
|
||||
|
||||
;; --- YearMonth: (vector year month) ------------------------------------------
|
||||
(define (jt-year-month y m)
|
||||
(let* ((ym (+ (* y 12) (- m 1))) (y2 (jt-floor-div ym 12)) (m2 (+ 1 (jt-floor-mod ym 12))))
|
||||
(make-jhost "year-month" (vector y2 m2))))
|
||||
(define (ym-year x) (vector-ref (jhost-state x) 0))
|
||||
(define (ym-month x) (vector-ref (jhost-state x) 1))
|
||||
(define (ym-plus-months x n)
|
||||
(let ((tm (+ (* (ym-year x) 12) (- (ym-month x) 1) n)))
|
||||
(make-jhost "year-month" (vector (jt-floor-div tm 12) (+ 1 (jt-floor-mod tm 12))))))
|
||||
(define (ym->string x) (string-append (pad4 (ym-year x)) "-" (pad2 (ym-month x))))
|
||||
(define (ym-from-temporal t)
|
||||
(cond ((and (jhost? t) (string=? (jhost-tag t) "year-month")) t)
|
||||
((jt-date? t) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) (lambda (y m d) (jt-year-month y m))))
|
||||
((jt-dt? t) (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day t))) (lambda (y m d) (jt-year-month y m))))
|
||||
(else (error #f "YearMonth/from: unsupported"))))
|
||||
(register-class-statics! "YearMonth"
|
||||
(list (cons "of" (lambda (y m) (jt-year-month (jt->exact y) (jt->exact m))))
|
||||
(cons "now" (lambda _ (call-with-values (lambda () (epoch-day->ymd (jt-floor-div (exact (truncate (now-ms))) 86400000)))
|
||||
(lambda (y m d) (jt-year-month y m)))))
|
||||
(cons "parse" (lambda (s . _) (let ((str (jt-str s)))
|
||||
(jt-year-month (or (digits-at str 0 4) (error #f "could not parse YearMonth"))
|
||||
(or (digits-at str 5 2) (error #f "could not parse YearMonth"))))))
|
||||
(cons "from" (lambda (t) (ym-from-temporal t)))))
|
||||
(register-host-methods! "year-month"
|
||||
(list (cons "getYear" (lambda (x) (ym-year x)))
|
||||
(cons "getMonthValue" (lambda (x) (ym-month x)))
|
||||
(cons "getMonth" (lambda (x) (jt-month (ym-month x))))
|
||||
(cons "lengthOfMonth" (lambda (x) (jt-len-of-month (ym-year x) (ym-month x))))
|
||||
(cons "lengthOfYear" (lambda (x) (if (jt-leap? (ym-year x)) 366 365)))
|
||||
(cons "isLeapYear" (lambda (x) (jt-leap? (ym-year x))))
|
||||
(cons "plusMonths" (lambda (x n) (ym-plus-months x (jt->exact n))))
|
||||
(cons "minusMonths" (lambda (x n) (ym-plus-months x (- (jt->exact n)))))
|
||||
(cons "plusYears" (lambda (x n) (jt-year-month (+ (ym-year x) (jt->exact n)) (ym-month x))))
|
||||
(cons "minusYears" (lambda (x n) (jt-year-month (- (ym-year x) (jt->exact n)) (ym-month x))))
|
||||
(cons "withYear" (lambda (x v) (jt-year-month (jt->exact v) (ym-month x))))
|
||||
(cons "withMonth" (lambda (x v) (jt-year-month (ym-year x) (jt->exact v))))
|
||||
(cons "atDay" (lambda (x d) (jt-local-date (ymd->epoch-day (ym-year x) (ym-month x) (jt->exact d)))))
|
||||
(cons "atEndOfMonth" (lambda (x) (jt-local-date (ymd->epoch-day (ym-year x) (ym-month x) (jt-len-of-month (ym-year x) (ym-month x))))))
|
||||
(cons "isValidDay" (lambda (x d) (let ((dd (jt->exact d))) (and (>= dd 1) (<= dd (jt-len-of-month (ym-year x) (ym-month x)))))))
|
||||
(cons "isBefore" (lambda (x o) (< (ym-cmp x o) 0)))
|
||||
(cons "isAfter" (lambda (x o) (> (ym-cmp x o) 0)))
|
||||
(cons "compareTo" (lambda (x o) (ym-cmp x o)))
|
||||
(cons "equals" (lambda (x o) (and (jhost? o) (string=? (jhost-tag o) "year-month") (= (ym-cmp x o) 0))))
|
||||
(cons "hashCode" (lambda (x) (+ (* (ym-year x) 13) (ym-month x))))
|
||||
(cons "toString" (lambda (x) (ym->string x)))))
|
||||
(define (ym-cmp x o)
|
||||
(cond ((< (ym-year x) (ym-year o)) -1) ((> (ym-year x) (ym-year o)) 1)
|
||||
((< (ym-month x) (ym-month o)) -1) ((> (ym-month x) (ym-month o)) 1) (else 0)))
|
||||
|
||||
;; --- ChronoUnit / ChronoField ------------------------------------------------
|
||||
;; Each ChronoUnit is a jhost (vector name nanos-or-#f) — nanos is the fixed
|
||||
;; duration in nanoseconds for time-based units, or an estimate for date-based ones.
|
||||
;; The conversion lets Duration/of and unit-based between/plus/until work.
|
||||
(define seconds-per-year (* (/ 146097 400) 86400)) ; 365.2425 days
|
||||
(define chrono-unit-table
|
||||
;; (name . nanos-per-unit) month/year use the average-length estimate java.time uses.
|
||||
(list (cons "NANOS" 1)
|
||||
(cons "MICROS" 1000)
|
||||
(cons "MILLIS" 1000000)
|
||||
(cons "SECONDS" nanos-per-sec)
|
||||
(cons "MINUTES" (* 60 nanos-per-sec))
|
||||
(cons "HOURS" (* 3600 nanos-per-sec))
|
||||
(cons "HALF_DAYS" (* 43200 nanos-per-sec))
|
||||
(cons "DAYS" (* 86400 nanos-per-sec))
|
||||
(cons "WEEKS" (* 7 86400 nanos-per-sec))
|
||||
(cons "MONTHS" (exact (round (* (/ seconds-per-year 12) nanos-per-sec))))
|
||||
(cons "YEARS" (exact (round (* seconds-per-year nanos-per-sec))))
|
||||
(cons "DECADES" (exact (round (* 10 seconds-per-year nanos-per-sec))))
|
||||
(cons "CENTURIES" (exact (round (* 100 seconds-per-year nanos-per-sec))))
|
||||
(cons "MILLENNIA" (exact (round (* 1000 seconds-per-year nanos-per-sec))))
|
||||
(cons "ERAS" (exact (round (* 1000000000 seconds-per-year nanos-per-sec))))
|
||||
(cons "FOREVER" #f)))
|
||||
(define (jt-chrono-unit name) (make-jhost "chrono-unit" (vector name)))
|
||||
(define (cu-name u) (vector-ref (jhost-state u) 0))
|
||||
(define (chrono-unit-nanos u)
|
||||
(let* ((nm (chrono-unit-name u)) (row (and nm (assoc (string-upcase nm) chrono-unit-table))))
|
||||
(if (and row (cdr row)) (cdr row) (error #f (string-append "no fixed duration for unit " (or nm "?"))))))
|
||||
;; register the 16 unit constants under ChronoUnit statics.
|
||||
(register-class-statics! "ChronoUnit"
|
||||
(append
|
||||
(map (lambda (row) (cons (car row) (jt-chrono-unit (car row)))) chrono-unit-table)
|
||||
(list (cons "valueOf" (lambda (s) (jt-chrono-unit (jt-str s))))
|
||||
(cons "values" (lambda () (make-pvec (list->vector (map (lambda (r) (jt-chrono-unit (car r))) chrono-unit-table))))))))
|
||||
(register-host-methods! "chrono-unit"
|
||||
(list (cons "name" (lambda (u) (cu-name u)))
|
||||
(cons "toString" (lambda (u) (cu-name u)))
|
||||
(cons "ordinal" (lambda (u) (let loop ((t chrono-unit-table) (i 0))
|
||||
(cond ((null? t) -1) ((string=? (caar t) (cu-name u)) i) (else (loop (cdr t) (+ i 1)))))))
|
||||
(cons "getDuration" (lambda (u) (dur-of-total-nanos (chrono-unit-nanos u))))
|
||||
(cons "isDateBased" (lambda (u) (and (member (cu-name u) '("DAYS" "WEEKS" "MONTHS" "YEARS" "DECADES" "CENTURIES" "MILLENNIA" "ERAS")) #t)))
|
||||
(cons "isTimeBased" (lambda (u) (and (member (cu-name u) '("NANOS" "MICROS" "MILLIS" "SECONDS" "MINUTES" "HOURS" "HALF_DAYS")) #t)))
|
||||
(cons "isDurationEstimated" (lambda (u) (and (member (cu-name u) '("DAYS" "WEEKS" "MONTHS" "YEARS" "DECADES" "CENTURIES" "MILLENNIA" "ERAS" "FOREVER")) #t)))
|
||||
(cons "between" (lambda (u a b) (unit-between (cu-name u) a b)))
|
||||
(cons "addTo" (lambda (u t n) (temporal-plus-unit t (jt->exact n) (cu-name u))))
|
||||
(cons "equals" (lambda (u o) (and (jhost? o) (string=? (jhost-tag o) "chrono-unit") (string=? (cu-name u) (cu-name o)))))
|
||||
(cons "hashCode" (lambda (u) (string-hash (cu-name u))))))
|
||||
|
||||
;; ChronoField: a jhost (vector name). get/getLong/with project the field onto a
|
||||
;; temporal via the field-projection table below.
|
||||
;; the full ChronoField enum (the cljc wrapper defs every constant at load). Only
|
||||
;; the common ones are projected by temporal-get-field; the rest exist as tokens.
|
||||
(define chrono-field-names
|
||||
'("NANO_OF_SECOND" "NANO_OF_DAY" "MICRO_OF_SECOND" "MICRO_OF_DAY" "MILLI_OF_SECOND" "MILLI_OF_DAY"
|
||||
"SECOND_OF_MINUTE" "SECOND_OF_DAY" "MINUTE_OF_HOUR" "MINUTE_OF_DAY"
|
||||
"HOUR_OF_AMPM" "CLOCK_HOUR_OF_AMPM" "HOUR_OF_DAY" "CLOCK_HOUR_OF_DAY" "AMPM_OF_DAY"
|
||||
"DAY_OF_WEEK" "ALIGNED_DAY_OF_WEEK_IN_MONTH" "ALIGNED_DAY_OF_WEEK_IN_YEAR"
|
||||
"DAY_OF_MONTH" "DAY_OF_YEAR" "EPOCH_DAY"
|
||||
"ALIGNED_WEEK_OF_MONTH" "ALIGNED_WEEK_OF_YEAR"
|
||||
"MONTH_OF_YEAR" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "YEAR" "ERA"
|
||||
"INSTANT_SECONDS" "OFFSET_SECONDS"))
|
||||
(define (jt-chrono-field name) (make-jhost "chrono-field" (vector name)))
|
||||
(define (cf-name f) (vector-ref (jhost-state f) 0))
|
||||
(register-class-statics! "ChronoField"
|
||||
(append
|
||||
(map (lambda (n) (cons n (jt-chrono-field n))) chrono-field-names)
|
||||
(list (cons "valueOf" (lambda (s) (jt-chrono-field (jt-str s))))
|
||||
(cons "values" (lambda () (make-pvec (list->vector (map jt-chrono-field chrono-field-names))))))))
|
||||
(register-host-methods! "chrono-field"
|
||||
(list (cons "name" (lambda (f) (cf-name f)))
|
||||
(cons "toString" (lambda (f) (cf-name f)))
|
||||
(cons "getDisplayName" (lambda (f . _) (cf-name f)))
|
||||
(cons "isDateBased" (lambda (f) (and (member (cf-name f) '("DAY_OF_WEEK" "DAY_OF_MONTH" "DAY_OF_YEAR" "EPOCH_DAY" "MONTH_OF_YEAR" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "YEAR" "ERA")) #t)))
|
||||
(cons "isTimeBased" (lambda (f) (not (member (cf-name f) '("DAY_OF_WEEK" "DAY_OF_MONTH" "DAY_OF_YEAR" "EPOCH_DAY" "MONTH_OF_YEAR" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "YEAR" "ERA" "INSTANT_SECONDS" "OFFSET_SECONDS")))))
|
||||
(cons "getFrom" (lambda (f t) (temporal-get-field t (cf-name f))))
|
||||
(cons "equals" (lambda (f o) (and (jhost? o) (string=? (jhost-tag o) "chrono-field") (string=? (cf-name f) (cf-name o)))))
|
||||
(cons "hashCode" (lambda (f) (string-hash (cf-name f))))))
|
||||
|
||||
;; --- ValueRange (minimal min/max holder) -------------------------------------
|
||||
(define (jt-value-range smin lmin smax lmax) (make-jhost "value-range" (vector smin lmin smax lmax)))
|
||||
(register-host-methods! "value-range"
|
||||
(list (cons "getMinimum" (lambda (r) (vector-ref (jhost-state r) 1)))
|
||||
(cons "getLargestMinimum" (lambda (r) (vector-ref (jhost-state r) 1)))
|
||||
(cons "getSmallestMaximum" (lambda (r) (vector-ref (jhost-state r) 2)))
|
||||
(cons "getMaximum" (lambda (r) (vector-ref (jhost-state r) 3)))
|
||||
(cons "isFixed" (lambda (r) (and (= (vector-ref (jhost-state r) 0) (vector-ref (jhost-state r) 1))
|
||||
(= (vector-ref (jhost-state r) 2) (vector-ref (jhost-state r) 3)))))
|
||||
(cons "isValidValue" (lambda (r v) (let ((x (jt->exact v))) (and (>= x (vector-ref (jhost-state r) 1)) (<= x (vector-ref (jhost-state r) 3))))))
|
||||
(cons "toString" (lambda (r) (string-append (number->string (vector-ref (jhost-state r) 1)) " - " (number->string (vector-ref (jhost-state r) 3)))))))
|
||||
|
||||
;; --- temporal field/unit machinery: plus/minus/until/get/with on core types --
|
||||
;; These power the generic cljc.java-time.temporal dispatchers, which forward to
|
||||
;; the receiver's plus/minus/until/get/getLong/with/range/isSupported.
|
||||
|
||||
;; add n of `unit` to a temporal (local-date / local-time / local-date-time / instant).
|
||||
(define (temporal-plus-unit t n unit)
|
||||
(let ((u (string-upcase unit)))
|
||||
(cond
|
||||
((jt-date? t)
|
||||
(cond ((string=? u "DAYS") (jt-local-date (+ (ld-epoch-day t) n)))
|
||||
((string=? u "WEEKS") (jt-local-date (+ (ld-epoch-day t) (* 7 n))))
|
||||
((string=? u "MONTHS") (ld-plus-months t n))
|
||||
((string=? u "YEARS") (ld-plus-years t n))
|
||||
((string=? u "DECADES") (ld-plus-years t (* 10 n)))
|
||||
((string=? u "CENTURIES") (ld-plus-years t (* 100 n)))
|
||||
((string=? u "MILLENNIA") (ld-plus-years t (* 1000 n)))
|
||||
(else (error #f (string-append "LocalDate plus unsupported unit " u)))))
|
||||
((jt-time? t) (lt-plus t (* n (chrono-unit-nanos (jt-chrono-unit u)))))
|
||||
((jt-dt? t)
|
||||
(cond ((string=? u "DAYS") (jt-local-dt (+ (ldt-epoch-day t) n) (ldt-nano-of-day t)))
|
||||
((string=? u "WEEKS") (jt-local-dt (+ (ldt-epoch-day t) (* 7 n)) (ldt-nano-of-day t)))
|
||||
((string=? u "MONTHS") (ldt-combine (ld-plus-months (ldt-date t) n) (ldt-time t)))
|
||||
((string=? u "YEARS") (ldt-combine (ld-plus-years (ldt-date t) n) (ldt-time t)))
|
||||
((string=? u "DECADES") (ldt-combine (ld-plus-years (ldt-date t) (* 10 n)) (ldt-time t)))
|
||||
((string=? u "CENTURIES") (ldt-combine (ld-plus-years (ldt-date t) (* 100 n)) (ldt-time t)))
|
||||
((string=? u "MILLENNIA") (ldt-combine (ld-plus-years (ldt-date t) (* 1000 n)) (ldt-time t)))
|
||||
(else (ldt-plus-nanos t (* n (chrono-unit-nanos (jt-chrono-unit u)))))))
|
||||
((jt-instant? t)
|
||||
(cond ((string=? u "DAYS") (mk-instant (+ (inst-ms t) (* n 86400000))))
|
||||
(else (mk-instant (+ (inst-ms t) (quotient (* n (chrono-unit-nanos (jt-chrono-unit u))) 1000000))))))
|
||||
(else (error #f "plus: unsupported temporal")))))
|
||||
|
||||
;; add raw nanos (for Duration.addTo).
|
||||
(define (temporal-plus-nanos t nanos)
|
||||
(cond ((jt-time? t) (lt-plus t nanos))
|
||||
((jt-dt? t) (ldt-plus-nanos t nanos))
|
||||
((jt-instant? t) (mk-instant (+ (inst-ms t) (quotient nanos 1000000))))
|
||||
((jt-date? t) (jt-local-date (+ (ld-epoch-day t) (quotient nanos (* 86400 nanos-per-sec)))))
|
||||
(else (error #f "plus(Duration): unsupported temporal"))))
|
||||
|
||||
;; add a Period (scaled by sign) to a date-bearing temporal.
|
||||
(define (temporal-plus-period t p sign)
|
||||
(let ((y (* sign (per-years p))) (m (* sign (per-months p))) (d (* sign (per-days p))))
|
||||
(cond ((jt-date? t) (jt-local-date (+ (ld-epoch-day (ld-plus-months (ld-plus-years t y) m)) d)))
|
||||
((jt-dt? t) (let ((nd (ld-plus-months (ld-plus-years (ldt-date t) y) m)))
|
||||
(jt-local-dt (+ (ld-epoch-day nd) d) (ldt-nano-of-day t))))
|
||||
(else (error #f "plus(Period): unsupported temporal")))))
|
||||
|
||||
;; count whole `unit`s from a to b.
|
||||
(define (unit-between unit a b)
|
||||
(let ((u (string-upcase unit)))
|
||||
(cond
|
||||
((and (jt-date? a) (jt-date? b))
|
||||
(let ((da (ld-epoch-day a)) (db (ld-epoch-day b)))
|
||||
(cond ((string=? u "DAYS") (- db da))
|
||||
((string=? u "WEEKS") (quotient (- db da) 7))
|
||||
((string=? u "MONTHS") (date-months-between da db))
|
||||
((string=? u "YEARS") (quotient (date-months-between da db) 12))
|
||||
((string=? u "DECADES") (quotient (date-months-between da db) 120))
|
||||
((string=? u "CENTURIES") (quotient (date-months-between da db) 1200))
|
||||
(else (error #f (string-append "between unsupported unit " u))))))
|
||||
((and (jt-time? a) (jt-time? b)) (quotient (- (lt-nano-of-day b) (lt-nano-of-day a)) (chrono-unit-nanos (jt-chrono-unit u))))
|
||||
((and (jt-dt? a) (jt-dt? b))
|
||||
(cond ((member u '("YEARS" "MONTHS" "DECADES" "CENTURIES" "MILLENNIA"))
|
||||
(unit-between u (ldt-date a) (ldt-date b))) ; date-based: ignore time-of-day below months on LDT? use date months adjusted
|
||||
(else (quotient (- (+ (* (ldt-epoch-day b) nanos-per-day) (ldt-nano-of-day b))
|
||||
(+ (* (ldt-epoch-day a) nanos-per-day) (ldt-nano-of-day a)))
|
||||
(chrono-unit-nanos (jt-chrono-unit u))))))
|
||||
((and (jt-instant? a) (jt-instant? b))
|
||||
(quotient (* (- (inst-ms b) (inst-ms a)) 1000000) (chrono-unit-nanos (jt-chrono-unit u))))
|
||||
(else (error #f "between: unsupported temporals")))))
|
||||
;; whole months between two epoch-days (java.time: months, then -1 if day-of-month
|
||||
;; of b hasn't reached a's).
|
||||
(define (date-months-between da db)
|
||||
(call-with-values (lambda () (epoch-day->ymd da))
|
||||
(lambda (y1 m1 d1)
|
||||
(call-with-values (lambda () (epoch-day->ymd db))
|
||||
(lambda (y2 m2 d2)
|
||||
(let ((months (- (+ (* y2 12) m2) (+ (* y1 12) m1))))
|
||||
(cond ((and (> months 0) (< d2 d1)) (- months 1))
|
||||
((and (< months 0) (> d2 d1)) (+ months 1))
|
||||
(else months))))))))
|
||||
|
||||
;; field get: project a ChronoField onto a temporal.
|
||||
(define (temporal-get-field t field)
|
||||
(let ((f (string-upcase field)))
|
||||
(cond
|
||||
((jt-date? t)
|
||||
(call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t)))
|
||||
(lambda (y m d)
|
||||
(cond ((string=? f "YEAR") y) ((string=? f "MONTH_OF_YEAR") m) ((string=? f "DAY_OF_MONTH") d)
|
||||
((string=? f "DAY_OF_WEEK") (ld-dow (ld-epoch-day t)))
|
||||
((string=? f "DAY_OF_YEAR") (ld-day-of-year (ld-epoch-day t)))
|
||||
((string=? f "EPOCH_DAY") (ld-epoch-day t))
|
||||
((string=? f "PROLEPTIC_MONTH") (+ (* y 12) (- m 1)))
|
||||
((string=? f "YEAR_OF_ERA") (if (>= y 1) y (- 1 y)))
|
||||
((string=? f "ERA") (if (>= y 1) 1 0))
|
||||
(else (error #f (string-append "LocalDate has no field " f)))))))
|
||||
((jt-time? t)
|
||||
(cond ((string=? f "HOUR_OF_DAY") (lt-hour t)) ((string=? f "MINUTE_OF_HOUR") (lt-minute t))
|
||||
((string=? f "SECOND_OF_MINUTE") (lt-second t)) ((string=? f "NANO_OF_SECOND") (lt-nano t))
|
||||
((string=? f "NANO_OF_DAY") (lt-nano-of-day t))
|
||||
((string=? f "MILLI_OF_DAY") (quotient (lt-nano-of-day t) 1000000))
|
||||
((string=? f "SECOND_OF_DAY") (quotient (lt-nano-of-day t) nanos-per-sec))
|
||||
((string=? f "MINUTE_OF_DAY") (quotient (lt-nano-of-day t) (* 60 nanos-per-sec)))
|
||||
((string=? f "MILLI_OF_SECOND") (quotient (lt-nano t) 1000000))
|
||||
((string=? f "MICRO_OF_SECOND") (quotient (lt-nano t) 1000))
|
||||
((string=? f "AMPM_OF_DAY") (quotient (lt-hour t) 12))
|
||||
(else (error #f (string-append "LocalTime has no field " f)))))
|
||||
((jt-dt? t)
|
||||
(if (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_WEEK" "DAY_OF_YEAR" "EPOCH_DAY" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "ERA"))
|
||||
(temporal-get-field (ldt-date t) f)
|
||||
(temporal-get-field (ldt-time t) f)))
|
||||
((jt-instant? t)
|
||||
(cond ((string=? f "INSTANT_SECONDS") (jt-floor-div (exact (truncate (inst-ms t))) 1000))
|
||||
((string=? f "NANO_OF_SECOND") (* (jt-floor-mod (exact (truncate (inst-ms t))) 1000) 1000000))
|
||||
((string=? f "MILLI_OF_SECOND") (jt-floor-mod (exact (truncate (inst-ms t))) 1000))
|
||||
(else (error #f (string-append "Instant has no field " f)))))
|
||||
(else (error #f "get(field): unsupported temporal")))))
|
||||
|
||||
;; field set: (with temporal ChronoField value) -> a new temporal.
|
||||
(define (temporal-with-field t field v)
|
||||
(let ((f (string-upcase field)))
|
||||
(cond
|
||||
((jt-date? t)
|
||||
(cond ((string=? f "YEAR") (ld-with-field t 'year v)) ((string=? f "MONTH_OF_YEAR") (ld-with-field t 'month v))
|
||||
((string=? f "DAY_OF_MONTH") (ld-with-field t 'day v)) ((string=? f "DAY_OF_YEAR") (ld-with-field t 'day-of-year v))
|
||||
((string=? f "EPOCH_DAY") (jt-local-date v))
|
||||
(else (error #f (string-append "LocalDate.with unsupported field " f)))))
|
||||
((jt-time? t)
|
||||
(cond ((string=? f "HOUR_OF_DAY") (lt-with t 'hour v)) ((string=? f "MINUTE_OF_HOUR") (lt-with t 'minute v))
|
||||
((string=? f "SECOND_OF_MINUTE") (lt-with t 'second v)) ((string=? f "NANO_OF_SECOND") (lt-with t 'nano v))
|
||||
((string=? f "NANO_OF_DAY") (jt-local-time v))
|
||||
(else (error #f (string-append "LocalTime.with unsupported field " f)))))
|
||||
((jt-dt? t)
|
||||
(if (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_YEAR" "EPOCH_DAY"))
|
||||
(ldt-combine (temporal-with-field (ldt-date t) f v) (ldt-time t))
|
||||
(ldt-combine (ldt-date t) (temporal-with-field (ldt-time t) f v))))
|
||||
(else (error #f "with(field): unsupported temporal")))))
|
||||
|
||||
(define (temporal-supports-unit? t unit)
|
||||
(let ((u (string-upcase unit)))
|
||||
(cond ((jt-date? t) (and (member u '("DAYS" "WEEKS" "MONTHS" "YEARS" "DECADES" "CENTURIES" "MILLENNIA" "ERAS")) #t))
|
||||
((jt-time? t) (and (member u '("NANOS" "MICROS" "MILLIS" "SECONDS" "MINUTES" "HOURS" "HALF_DAYS")) #t))
|
||||
((or (jt-dt? t) (jt-instant? t)) (not (member u '("FOREVER"))))
|
||||
(else #f))))
|
||||
(define (temporal-supports-field? t field)
|
||||
(let ((f (string-upcase field)))
|
||||
(cond ((jt-date? t) (and (member f '("YEAR" "MONTH_OF_YEAR" "DAY_OF_MONTH" "DAY_OF_WEEK" "DAY_OF_YEAR" "EPOCH_DAY" "PROLEPTIC_MONTH" "YEAR_OF_ERA" "ERA")) #t))
|
||||
((jt-time? t) (and (member f '("HOUR_OF_DAY" "MINUTE_OF_HOUR" "SECOND_OF_MINUTE" "NANO_OF_SECOND" "NANO_OF_DAY" "MILLI_OF_DAY" "SECOND_OF_DAY" "MINUTE_OF_DAY" "MILLI_OF_SECOND" "MICRO_OF_SECOND" "AMPM_OF_DAY")) #t))
|
||||
((jt-dt? t) (or (temporal-supports-field? (ldt-date t) field) (temporal-supports-field? (ldt-time t) field)))
|
||||
((jt-instant? t) (and (member f '("INSTANT_SECONDS" "NANO_OF_SECOND" "MILLI_OF_SECOND" "MICRO_OF_SECOND")) #t))
|
||||
(else #f))))
|
||||
|
||||
;; isSupported / get / getLong / with / range / plus / minus / until accept a
|
||||
;; chrono-unit OR chrono-field jhost (or a string). These method names extend the
|
||||
;; existing per-tag tables.
|
||||
(define (unit-or-field-arg x) x)
|
||||
(define (arg-is-unit? x) (and (jhost? x) (string=? (jhost-tag x) "chrono-unit")))
|
||||
(define (arg-is-field? x) (and (jhost? x) (string=? (jhost-tag x) "chrono-field")))
|
||||
(define (arg-is-amount? x) (and (jhost? x) (member (jhost-tag x) '("duration" "period"))))
|
||||
(define (arg-unit-name x) (cond ((arg-is-unit? x) (cu-name x)) ((string? x) x) ((keyword? x) (keyword-t-name x)) (else #f)))
|
||||
(define (arg-field-name x) (cond ((arg-is-field? x) (cf-name x)) ((string? x) x) ((keyword? x) (keyword-t-name x)) (else #f)))
|
||||
|
||||
;; the generic plus/minus/until/get/getLong/with/range/isSupported, shared by all
|
||||
;; four core tags. plus/minus accept (n unit) or (amount); with accepts (field val).
|
||||
(define (mk-temporal-methods)
|
||||
(list
|
||||
(cons "plus" (case-lambda
|
||||
((t a) (cond ((arg-is-amount? a) (if (string=? (jhost-tag a) "duration")
|
||||
(temporal-plus-nanos t (dur-total-nanos a))
|
||||
(temporal-plus-period t a 1)))
|
||||
(else (error #f "plus: bad amount"))))
|
||||
((t n u) (temporal-plus-unit t (jt->exact n) (arg-unit-name u)))))
|
||||
(cons "minus" (case-lambda
|
||||
((t a) (cond ((arg-is-amount? a) (if (string=? (jhost-tag a) "duration")
|
||||
(temporal-plus-nanos t (- (dur-total-nanos a)))
|
||||
(temporal-plus-period t a -1)))
|
||||
(else (error #f "minus: bad amount"))))
|
||||
((t n u) (temporal-plus-unit t (- (jt->exact n)) (arg-unit-name u)))))
|
||||
(cons "until" (lambda (t o u) (unit-between (arg-unit-name u) t o)))
|
||||
(cons "get" (lambda (t f) (temporal-get-field t (arg-field-name f))))
|
||||
(cons "getLong" (lambda (t f) (temporal-get-field t (arg-field-name f))))
|
||||
(cons "with" (lambda (t f v) (temporal-with-field t (arg-field-name f) (jt->exact v))))
|
||||
(cons "isSupported" (lambda (t x) (cond ((arg-is-unit? x) (temporal-supports-unit? t (cu-name x)))
|
||||
((arg-is-field? x) (temporal-supports-field? t (cf-name x)))
|
||||
(else #f))))
|
||||
(cons "range" (lambda (t f) (temporal-range t (arg-field-name f))))))
|
||||
(register-host-methods! "local-date" (mk-temporal-methods))
|
||||
(register-host-methods! "local-time" (mk-temporal-methods))
|
||||
(register-host-methods! "local-date-time" (mk-temporal-methods))
|
||||
(register-host-methods! "instant" (mk-temporal-methods))
|
||||
|
||||
;; range(field): a ValueRange. A small set of common fields; others fall back to a
|
||||
;; generous range so callers that only read min/max don't crash.
|
||||
(define (temporal-range t field)
|
||||
(let ((f (string-upcase field)))
|
||||
(cond
|
||||
((and (jt-date? t) (string=? f "DAY_OF_MONTH"))
|
||||
(jt-value-range 1 1 28 (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day t))) (lambda (y m d) (jt-len-of-month y m)))))
|
||||
((string=? f "MONTH_OF_YEAR") (jt-value-range 1 1 12 12))
|
||||
((string=? f "DAY_OF_WEEK") (jt-value-range 1 1 7 7))
|
||||
((string=? f "HOUR_OF_DAY") (jt-value-range 0 0 23 23))
|
||||
((string=? f "MINUTE_OF_HOUR") (jt-value-range 0 0 59 59))
|
||||
((string=? f "SECOND_OF_MINUTE") (jt-value-range 0 0 59 59))
|
||||
((string=? f "NANO_OF_SECOND") (jt-value-range 0 0 999999999 999999999))
|
||||
(else (jt-value-range 0 0 999999999999 999999999999)))))
|
||||
|
||||
;; --- equality / hash / compare / print / instance? --------------------------
|
||||
(define (jt-date? x) (and (jhost? x) (string=? (jhost-tag x) "local-date")))
|
||||
|
|
@ -492,6 +1182,25 @@
|
|||
(register-str-render! jt-instant? (lambda (x) (iso-instant-str (inst-ms x))))
|
||||
(register-pr-arm! jt-instant? (lambda (x) (iso-instant-str (inst-ms x))))
|
||||
|
||||
;; Phase-2 value types: amounts, enums, and the chrono-unit/field tokens. Each
|
||||
;; prints as its java.time toString and is = / hashed on its canonical state.
|
||||
(define (jt-tagged? tag) (lambda (x) (and (jhost? x) (string=? (jhost-tag x) tag))))
|
||||
(define (register-jt-value! tag str-fn hash-fn)
|
||||
(let ((pred (jt-tagged? tag)))
|
||||
(register-str-render! pred str-fn)
|
||||
(register-pr-arm! pred str-fn)
|
||||
(register-eq-arm! (lambda (a b) (or (pred a) (pred b)))
|
||||
(lambda (a b) (and (pred a) (pred b) (equal? (jhost-state a) (jhost-state b)))))
|
||||
(register-hash-arm! pred hash-fn)))
|
||||
(register-jt-value! "duration" dur->string (lambda (x) (jolt-hash (dur-total-nanos x))))
|
||||
(register-jt-value! "period" per->string (lambda (x) (jolt-hash (+ (per-years x) (per-months x) (per-days x)))))
|
||||
(register-jt-value! "month-enum" (lambda (x) (month-name (month-val x))) (lambda (x) (jolt-hash (month-val x))))
|
||||
(register-jt-value! "dow-enum" (lambda (x) (dow-name (dow-val x))) (lambda (x) (jolt-hash (dow-val x))))
|
||||
(register-jt-value! "year" (lambda (x) (number->string (year-val x))) (lambda (x) (jolt-hash (year-val x))))
|
||||
(register-jt-value! "year-month" ym->string (lambda (x) (jolt-hash (+ (* (ym-year x) 13) (ym-month x)))))
|
||||
(register-jt-value! "chrono-unit" cu-name (lambda (x) (jolt-hash (cu-name x))))
|
||||
(register-jt-value! "chrono-field" cf-name (lambda (x) (jolt-hash (cf-name x))))
|
||||
|
||||
;; compare: same-type java.time values compare on their canonical state.
|
||||
(define %jt-prev-compare jolt-compare)
|
||||
(set! jolt-compare
|
||||
|
|
@ -501,7 +1210,15 @@
|
|||
((and (jt-time? a) (jt-time? b)) (cond ((< (lt-nano-of-day a) (lt-nano-of-day b)) -1) ((> (lt-nano-of-day a) (lt-nano-of-day b)) 1) (else 0)))
|
||||
((and (jt-dt? a) (jt-dt? b)) (ldt-cmp a b))
|
||||
((and (jt-instant? a) (jt-instant? b)) (cond ((< (inst-ms a) (inst-ms b)) -1) ((> (inst-ms a) (inst-ms b)) 1) (else 0)))
|
||||
((and (jt-tagged-as? a "duration") (jt-tagged-as? b "duration"))
|
||||
(let ((x (dur-total-nanos a)) (y (dur-total-nanos b))) (cond ((< x y) -1) ((> x y) 1) (else 0))))
|
||||
((and (jt-tagged-as? a "month-enum") (jt-tagged-as? b "month-enum")) (- (month-val a) (month-val b)))
|
||||
((and (jt-tagged-as? a "dow-enum") (jt-tagged-as? b "dow-enum")) (- (dow-val a) (dow-val b)))
|
||||
((and (jt-tagged-as? a "year") (jt-tagged-as? b "year"))
|
||||
(let ((x (year-val a)) (y (year-val b))) (cond ((< x y) -1) ((> x y) 1) (else 0))))
|
||||
((and (jt-tagged-as? a "year-month") (jt-tagged-as? b "year-month")) (ym-cmp a b))
|
||||
(else (%jt-prev-compare a b)))))
|
||||
(define (jt-tagged-as? x tag) (and (jhost? x) (string=? (jhost-tag x) tag)))
|
||||
(def-var! "clojure.core" "compare" jolt-compare)
|
||||
|
||||
;; instance? for the three new tags (inst-time.ss already answers "instant").
|
||||
|
|
@ -512,4 +1229,12 @@
|
|||
((jt-date? val) (if (string=? tn "LocalDate") #t 'pass))
|
||||
((jt-time? val) (if (string=? tn "LocalTime") #t 'pass))
|
||||
((jt-dt? val) (if (string=? tn "LocalDateTime") #t 'pass))
|
||||
((jt-tagged-as? val "duration") (if (member tn '("Duration" "TemporalAmount")) #t 'pass))
|
||||
((jt-tagged-as? val "period") (if (member tn '("Period" "TemporalAmount")) #t 'pass))
|
||||
((jt-tagged-as? val "month-enum") (if (string=? tn "Month") #t 'pass))
|
||||
((jt-tagged-as? val "dow-enum") (if (string=? tn "DayOfWeek") #t 'pass))
|
||||
((jt-tagged-as? val "year") (if (string=? tn "Year") #t 'pass))
|
||||
((jt-tagged-as? val "year-month") (if (string=? tn "YearMonth") #t 'pass))
|
||||
((jt-tagged-as? val "chrono-unit") (if (member tn '("ChronoUnit" "TemporalUnit")) #t 'pass))
|
||||
((jt-tagged-as? val "chrono-field") (if (member tn '("ChronoField" "TemporalField")) #t 'pass))
|
||||
(else 'pass)))))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue