;; java.time core value types: LocalDate, LocalTime, LocalDateTime, Instant. ;; ;; Each is a tz-free jhost over an integer state: ;; local-date (vector epoch-day) day number from 1970-01-01 ;; local-time (vector nano-of-day) [0, 86_400_000_000_000) ;; local-dt (vector epoch-day nano-of-day) ;; instant (vector epoch-ms) reused from inst-time.ss ;; ;; The cljc.java-time wrappers are thin interop over these — static factories ;; (LocalDate/of …) reach register-class-statics!, instance methods reach the ;; per-tag method tables. Equality / hash / compare / print / instance? / protocol ;; dispatch are wired through the host registries. ;; ;; Precision: Instant is millisecond-granular (it carries epoch-ms only). get-nano ;; reports (ms-sub-second * 1e6); plus-nanos / plus-millis round to the millisecond. ;; LocalTime / LocalDateTime carry full nanosecond precision. ;; --- shared helpers ---------------------------------------------------------- (define nanos-per-day 86400000000000) (define nanos-per-sec 1000000000) (define (jt-floor-div a b) (let ((q (quotient a b)) (r (remainder a b))) (if (and (not (= r 0)) (< (* a b) 0)) (- q 1) q))) (define (jt-floor-mod a b) (- a (* (jt-floor-div a b) b))) (define (jt->exact n) (cond ((and (number? n) (exact? n) (integer? n)) n) ((number? n) (exact (truncate n))) (else (error #f "java.time: not an integer" n)))) (define (jt-leap? y) (and (= 0 (modulo y 4)) (or (not (= 0 (modulo y 100))) (= 0 (modulo y 400))))) (define (jt-len-of-month y m) (cond ((= m 2) (if (jt-leap? y) 29 28)) ((memv m '(4 6 9 11)) 30) (else 31))) ;; constructors (define (jt-local-date ed) (make-jhost "local-date" (vector ed))) (define (jt-local-time nod) (make-jhost "local-time" (vector nod))) (define (jt-local-dt ed nod) (make-jhost "local-date-time" (vector ed nod))) ;; state accessors (define (ld-epoch-day d) (vector-ref (jhost-state d) 0)) (define (lt-nano-of-day t) (vector-ref (jhost-state t) 0)) ;; the LocalDateTime jhost uses tag "local-date-time" with [epoch-day nano-of-day]. ;; inst-time.ss's ms-based "local-dt" tag stays for the #inst formatting shim. (define (ldt-epoch-day x) (vector-ref (jhost-state x) 0)) (define (ldt-nano-of-day x) (vector-ref (jhost-state x) 1)) ;; civil <-> epoch-day (inst-time.ss owns days-from-civil / civil-from-days) (define (ymd->epoch-day y m d) (days-from-civil y m d)) (define (epoch-day->ymd ed) (civil-from-days ed)) ; -> (values y m d) ;; build a LocalDate, normalizing month/day overflow the way java.time does: ;; the year/month roll, then the day is clamped to the month length. (define (jt-date-of y m d) (let* ((ym (+ (* y 12) (- m 1))) (y2 (jt-floor-div ym 12)) (m2 (+ 1 (jt-floor-mod ym 12))) (dom (min d (jt-len-of-month y2 m2)))) (jt-local-date (ymd->epoch-day y2 m2 dom)))) ;; day-of-week: 1970-01-01 is Thursday; java.time DayOfWeek is 1=Mon..7=Sun. (define (ld-dow ed) (+ 1 (jt-floor-mod (+ ed 3) 7))) (define jt-day-names (vector "MONDAY" "TUESDAY" "WEDNESDAY" "THURSDAY" "FRIDAY" "SATURDAY" "SUNDAY")) (define jt-month-names (vector "JANUARY" "FEBRUARY" "MARCH" "APRIL" "MAY" "JUNE" "JULY" "AUGUST" "SEPTEMBER" "OCTOBER" "NOVEMBER" "DECEMBER")) (define (ld-day-of-year ed) (call-with-values (lambda () (epoch-day->ymd ed)) (lambda (y m d) (+ 1 (- ed (ymd->epoch-day y 1 1)))))) ;; nano-of-day <-> (h m s nano) (define (hmsn->nano h m s nano) (+ (* (+ (* h 3600) (* m 60) s) nanos-per-sec) nano)) (define (lt-hour t) (quotient (lt-nano-of-day t) (* 3600 nanos-per-sec))) (define (lt-minute t) (modulo (quotient (lt-nano-of-day t) (* 60 nanos-per-sec)) 60)) (define (lt-second t) (modulo (quotient (lt-nano-of-day t) nanos-per-sec) 60)) (define (lt-nano t) (modulo (lt-nano-of-day t) nanos-per-sec)) ;; --- ISO-8601 rendering ------------------------------------------------------ (define (iso-date-str ed) (call-with-values (lambda () (epoch-day->ymd ed)) (lambda (y m d) (string-append (pad4 y) "-" (pad2 m) "-" (pad2 d))))) ;; LocalTime: "HH:mm", "HH:mm:ss", or with a fractional second (3/6/9 digits). (define (frac-digits nano) (cond ((= 0 (modulo nano 1000000)) (let ((s (number->string (quotient nano 1000000)))) (string-append (make-string (max 0 (- 3 (string-length s))) #\0) s))) ((= 0 (modulo nano 1000)) (let ((s (number->string (quotient nano 1000)))) (string-append (make-string (max 0 (- 6 (string-length s))) #\0) s))) (else (let ((s (number->string nano))) (string-append (make-string (max 0 (- 9 (string-length s))) #\0) s))))) (define (iso-time-str nod) (let ((h (quotient nod (* 3600 nanos-per-sec))) (mi (modulo (quotient nod (* 60 nanos-per-sec)) 60)) (s (modulo (quotient nod nanos-per-sec) 60)) (nano (modulo nod nanos-per-sec))) (string-append (pad2 h) ":" (pad2 mi) (if (and (= s 0) (= nano 0)) "" (string-append ":" (pad2 s) (if (= nano 0) "" (string-append "." (frac-digits nano)))))))) (define (iso-datetime-str ed nod) (string-append (iso-date-str ed) "T" (iso-time-str nod))) ;; Instant: always UTC with a trailing Z; seconds always shown, millis only when nonzero. (define (iso-instant-str ms) (let* ((ems (exact (truncate ms))) (secs (jt-floor-div ems 1000)) (frac (- ems (* secs 1000))) (ed (jt-floor-div secs 86400)) (sod (jt-floor-mod secs 86400)) (nod (* (+ (* (quotient sod 3600) 3600) (* (quotient (modulo sod 3600) 60) 60) (modulo sod 60)) nanos-per-sec))) (string-append (iso-date-str ed) "T" (pad2 (quotient sod 3600)) ":" (pad2 (modulo (quotient sod 60) 60)) ":" (pad2 (modulo sod 60)) (if (= frac 0) "" (string-append "." (frac-digits (* frac 1000000)))) "Z"))) ;; --- ISO parsing ------------------------------------------------------------- (define (jt-str x) (if (string? x) x (jolt-str-render-one x))) ;; "yyyy-MM-dd" -> epoch-day (define (parse-iso-date s) (let ((y (digits-at s 0 4)) (m (digits-at s 5 2)) (d (digits-at s 8 2))) (if (and y m d (char=? (string-ref s 4) #\-) (char=? (string-ref s 7) #\-)) (ymd->epoch-day y m d) (error #f (string-append "could not parse LocalDate: " s))))) ;; "HH:mm[:ss[.fff…]]" -> nano-of-day (define (parse-iso-time s) (let ((len (string-length s))) (let ((h (digits-at s 0 2)) (mi (digits-at s 3 2))) (unless (and h mi (char=? (string-ref s 2) #\:)) (error #f (string-append "could not parse LocalTime: " s))) (let ((s2 (and (> len 5) (char=? (string-ref s 5) #\:) (digits-at s 6 2)))) (if (not s2) (hmsn->nano h mi 0 0) (let loop ((i 8) (nano 0)) ; optional .fraction (if (and (< i len) (char=? (string-ref s 8) #\.)) (let frac ((j 9) (k 0) (acc 0)) (if (and (< j len) (digit? (string-ref s j))) (frac (+ j 1) (+ k 1) (+ (* acc 10) (- (char->integer (string-ref s j)) 48))) (hmsn->nano h mi s2 (* acc (expt 10 (max 0 (- 9 k))))))) (hmsn->nano h mi s2 0)))))))) ;; "yyyy-MM-ddTHH:mm[:ss[.fff]]" -> (values epoch-day nano-of-day) (define (parse-iso-datetime s) (let ((ti (let loop ((i 0)) (cond ((>= i (string-length s)) #f) ((or (char=? (string-ref s i) #\T) (char=? (string-ref s i) #\t)) i) (else (loop (+ i 1))))))) (unless ti (error #f (string-append "could not parse LocalDateTime: " s))) (values (parse-iso-date (substring s 0 ti)) (parse-iso-time (substring s (+ ti 1) (string-length s)))))) ;; --- 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))) (register-class-statics! "LocalDate" (list (cons "of" (lambda (y m d) (jt-date-of (jt->exact y) (jt->exact m) (jt->exact d)))) (cons "ofEpochDay" (lambda (n) (jt-local-date (jt->exact n)))) (cons "ofYearDay" (lambda (y doy) (jt-local-date (+ (ymd->epoch-day (jt->exact y) 1 1) (- (jt->exact doy) 1))))) (cons "parse" (lambda (s . _) (jt-local-date (parse-iso-date (jt-str s))))) (cons "now" (lambda _ (mk-local-date (now-ms)))) (cons "from" (lambda (t) (cond ((and (jhost? t) (string=? (jhost-tag t) "local-date")) t) ((and (jhost? t) (string=? (jhost-tag t) "local-date-time")) (jt-local-date (ldt-epoch-day t))) (else (mk-local-date (ms-of t)))))) (cons "MIN" ld-min) (cons "MAX" ld-max))) (define (ld-plus-months d n) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dom) (let* ((ym (+ (* y 12) (- m 1) n)) (y2 (jt-floor-div ym 12)) (m2 (+ 1 (jt-floor-mod ym 12)))) (jt-local-date (ymd->epoch-day y2 m2 (min dom (jt-len-of-month y2 m2)))))))) (define (ld-plus-years d n) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dom) (jt-local-date (ymd->epoch-day (+ y n) m (min dom (jt-len-of-month (+ y n) m))))))) (define (ld-with-field d which v) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dom) (case which ((year) (jt-local-date (ymd->epoch-day v m (min dom (jt-len-of-month v m))))) ((month) (jt-local-date (ymd->epoch-day y v (min dom (jt-len-of-month y v))))) ((day) (jt-local-date (ymd->epoch-day y m v))) ((day-of-year) (jt-local-date (+ (ymd->epoch-day y 1 1) (- v 1)))))))) (register-host-methods! "local-date" (list (cons "getYear" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) y)))) (cons "getMonthValue" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) m)))) (cons "getDayOfMonth" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) dd)))) (cons "getMonth" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) (make-jhost "month-enum" (vector m)))))) (cons "getDayOfWeek" (lambda (d) (make-jhost "dow-enum" (vector (ld-dow (ld-epoch-day d)))))) (cons "getDayOfYear" (lambda (d) (ld-day-of-year (ld-epoch-day d)))) (cons "toEpochDay" (lambda (d) (ld-epoch-day d))) (cons "lengthOfMonth" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) (jt-len-of-month y m))))) (cons "lengthOfYear" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) (if (jt-leap? y) 366 365))))) (cons "isLeapYear" (lambda (d) (call-with-values (lambda () (epoch-day->ymd (ld-epoch-day d))) (lambda (y m dd) (jt-leap? y))))) (cons "plusDays" (lambda (d n) (jt-local-date (+ (ld-epoch-day d) (jt->exact n))))) (cons "minusDays" (lambda (d n) (jt-local-date (- (ld-epoch-day d) (jt->exact n))))) (cons "plusWeeks" (lambda (d n) (jt-local-date (+ (ld-epoch-day d) (* 7 (jt->exact n)))))) (cons "minusWeeks" (lambda (d n) (jt-local-date (- (ld-epoch-day d) (* 7 (jt->exact n)))))) (cons "plusMonths" (lambda (d n) (ld-plus-months d (jt->exact n)))) (cons "minusMonths" (lambda (d n) (ld-plus-months d (- (jt->exact n))))) (cons "plusYears" (lambda (d n) (ld-plus-years d (jt->exact n)))) (cons "minusYears" (lambda (d n) (ld-plus-years d (- (jt->exact n))))) (cons "withYear" (lambda (d v) (ld-with-field d 'year (jt->exact v)))) (cons "withMonth" (lambda (d v) (ld-with-field d 'month (jt->exact v)))) (cons "withDayOfMonth" (lambda (d v) (ld-with-field d 'day (jt->exact v)))) (cons "withDayOfYear" (lambda (d v) (ld-with-field d 'day-of-year (jt->exact v)))) (cons "isBefore" (lambda (d o) (< (ld-epoch-day d) (ld-epoch-day o)))) (cons "isAfter" (lambda (d o) (> (ld-epoch-day d) (ld-epoch-day o)))) (cons "isEqual" (lambda (d o) (= (ld-epoch-day d) (ld-epoch-day o)))) (cons "compareTo" (lambda (d o) (let ((a (ld-epoch-day d)) (b (ld-epoch-day o))) (cond ((< a b) -1) ((> a b) 1) (else 0))))) (cons "equals" (lambda (d o) (and (jhost? o) (string=? (jhost-tag o) "local-date") (= (ld-epoch-day d) (ld-epoch-day o))))) (cons "hashCode" (lambda (d) (ld-epoch-day d))) (cons "atStartOfDay" (lambda (d . _) (jt-local-dt (ld-epoch-day d) 0))) (cons "atTime" (case-lambda ((d t) (if (and (jhost? t) (string=? (jhost-tag t) "local-time")) (jt-local-dt (ld-epoch-day d) (lt-nano-of-day t)) (error #f "atTime: expected LocalTime"))) ((d h m) (jt-local-dt (ld-epoch-day d) (hmsn->nano (jt->exact h) (jt->exact m) 0 0))) ((d h m s) (jt-local-dt (ld-epoch-day d) (hmsn->nano (jt->exact h) (jt->exact m) (jt->exact s) 0))) ((d h m s nano) (jt-local-dt (ld-epoch-day d) (hmsn->nano (jt->exact h) (jt->exact m) (jt->exact s) (jt->exact nano)))))) (cons "toString" (lambda (d) (iso-date-str (ld-epoch-day d)))))) ;; --- LocalTime --------------------------------------------------------------- (define lt-min (jt-local-time 0)) (define lt-max (jt-local-time (- nanos-per-day 1))) (register-class-statics! "LocalTime" (list (cons "of" (case-lambda ((h m) (jt-local-time (hmsn->nano (jt->exact h) (jt->exact m) 0 0))) ((h m s) (jt-local-time (hmsn->nano (jt->exact h) (jt->exact m) (jt->exact s) 0))) ((h m s nano) (jt-local-time (hmsn->nano (jt->exact h) (jt->exact m) (jt->exact s) (jt->exact nano)))))) (cons "ofNanoOfDay" (lambda (n) (jt-local-time (jt->exact n)))) (cons "ofSecondOfDay" (lambda (n) (jt-local-time (* (jt->exact n) nanos-per-sec)))) (cons "parse" (lambda (s . _) (jt-local-time (parse-iso-time (jt-str s))))) (cons "now" (lambda _ (jt-local-time (let ((ms (now-ms))) (* (jt-floor-mod (exact (truncate ms)) 86400000) 1000000))))) (cons "from" (lambda (t) (cond ((and (jhost? t) (string=? (jhost-tag t) "local-time")) t) ((and (jhost? t) (string=? (jhost-tag t) "local-date-time")) (jt-local-time (ldt-nano-of-day t))) (else (error #f "LocalTime/from: unsupported"))))) (cons "MIN" lt-min) (cons "MAX" lt-max) (cons "MIDNIGHT" (jt-local-time 0)) (cons "NOON" (jt-local-time (* 12 3600 nanos-per-sec))))) (define (lt-plus t nanos) (jt-local-time (jt-floor-mod (+ (lt-nano-of-day t) nanos) nanos-per-day))) (define (lt-with t which v) (let ((h (lt-hour t)) (mi (lt-minute t)) (s (lt-second t)) (nano (lt-nano t))) (case which ((hour) (jt-local-time (hmsn->nano v mi s nano))) ((minute) (jt-local-time (hmsn->nano h v s nano))) ((second) (jt-local-time (hmsn->nano h mi v nano))) ((nano) (jt-local-time (hmsn->nano h mi s v)))))) (register-host-methods! "local-time" (list (cons "getHour" (lambda (t) (lt-hour t))) (cons "getMinute" (lambda (t) (lt-minute t))) (cons "getSecond" (lambda (t) (lt-second t))) (cons "getNano" (lambda (t) (lt-nano t))) (cons "toNanoOfDay" (lambda (t) (lt-nano-of-day t))) (cons "toSecondOfDay" (lambda (t) (quotient (lt-nano-of-day t) nanos-per-sec))) (cons "plusHours" (lambda (t n) (lt-plus t (* (jt->exact n) 3600 nanos-per-sec)))) (cons "minusHours" (lambda (t n) (lt-plus t (- (* (jt->exact n) 3600 nanos-per-sec))))) (cons "plusMinutes" (lambda (t n) (lt-plus t (* (jt->exact n) 60 nanos-per-sec)))) (cons "minusMinutes" (lambda (t n) (lt-plus t (- (* (jt->exact n) 60 nanos-per-sec))))) (cons "plusSeconds" (lambda (t n) (lt-plus t (* (jt->exact n) nanos-per-sec)))) (cons "minusSeconds" (lambda (t n) (lt-plus t (- (* (jt->exact n) nanos-per-sec))))) (cons "plusNanos" (lambda (t n) (lt-plus t (jt->exact n)))) (cons "minusNanos" (lambda (t n) (lt-plus t (- (jt->exact n))))) (cons "withHour" (lambda (t v) (lt-with t 'hour (jt->exact v)))) (cons "withMinute" (lambda (t v) (lt-with t 'minute (jt->exact v)))) (cons "withSecond" (lambda (t v) (lt-with t 'second (jt->exact v)))) (cons "withNano" (lambda (t v) (lt-with t 'nano (jt->exact v)))) (cons "truncatedTo" (lambda (t u) (lt-truncate t u))) (cons "isBefore" (lambda (t o) (< (lt-nano-of-day t) (lt-nano-of-day o)))) (cons "isAfter" (lambda (t o) (> (lt-nano-of-day t) (lt-nano-of-day o)))) (cons "compareTo" (lambda (t o) (let ((a (lt-nano-of-day t)) (b (lt-nano-of-day o))) (cond ((< a b) -1) ((> a b) 1) (else 0))))) (cons "equals" (lambda (t o) (and (jhost? o) (string=? (jhost-tag o) "local-time") (= (lt-nano-of-day t) (lt-nano-of-day o))))) (cons "hashCode" (lambda (t) (lt-nano-of-day t))) (cons "atDate" (lambda (t d) (jt-local-dt (ld-epoch-day d) (lt-nano-of-day t)))) (cons "toString" (lambda (t) (iso-time-str (lt-nano-of-day t)))))) ;; truncatedTo a ChronoUnit: zero out below the unit. The unit arrives as a ;; chrono-unit jhost (name) or a keyword/string; common units only. (define (chrono-unit-name u) (cond ((and (jhost? u) (string=? (jhost-tag u) "chrono-unit")) (vector-ref (jhost-state u) 0)) ((string? u) u) ((keyword? u) (keyword-t-name u)) (else #f))) (define (lt-truncate t u) (let* ((nod (lt-nano-of-day t)) (unit (chrono-unit-name u)) (div (cond ((not unit) 1) ((string-ci=? unit "NANOS") 1) ((string-ci=? unit "MICROS") 1000) ((string-ci=? unit "MILLIS") 1000000) ((string-ci=? unit "SECONDS") nanos-per-sec) ((string-ci=? unit "MINUTES") (* 60 nanos-per-sec)) ((string-ci=? unit "HOURS") (* 3600 nanos-per-sec)) ((string-ci=? unit "DAYS") nanos-per-day) (else 1)))) (jt-local-time (* (quotient nod div) div)))) ;; --- LocalDateTime ----------------------------------------------------------- (define ldt-min (jt-local-dt (ymd->epoch-day -999999999 1 1) 0)) (define ldt-max (jt-local-dt (ymd->epoch-day 999999999 12 31) (- nanos-per-day 1))) ;; epoch-seconds at a zero offset (the tz-free layer treats LocalDateTime as UTC). (define (ldt->epoch-second x) (+ (* (ldt-epoch-day x) 86400) (quotient (ldt-nano-of-day x) nanos-per-sec))) (define (ldt->ms x) (+ (* (ldt-epoch-day x) 86400000) (quotient (ldt-nano-of-day x) 1000000))) (register-class-statics! "LocalDateTime" (list (cons "of" (case-lambda ((d t) (jt-local-dt (ld-epoch-day d) (lt-nano-of-day t))) ; (LocalDate LocalTime) ((y mo d h mi) (jt-local-dt (ymd->epoch-day (jt->exact y) (jt->exact mo) (jt->exact d)) (hmsn->nano (jt->exact h) (jt->exact mi) 0 0))) ((y mo d h mi s) (jt-local-dt (ymd->epoch-day (jt->exact y) (jt->exact mo) (jt->exact d)) (hmsn->nano (jt->exact h) (jt->exact mi) (jt->exact s) 0))) ((y mo d h mi s nano) (jt-local-dt (ymd->epoch-day (jt->exact y) (jt->exact mo) (jt->exact d)) (hmsn->nano (jt->exact h) (jt->exact mi) (jt->exact s) (jt->exact nano)))))) (cons "ofEpochSecond" (lambda (secs nano off) (let ((es (jt->exact secs))) (jt-local-dt (jt-floor-div es 86400) (+ (* (jt-floor-mod es 86400) nanos-per-sec) (jt->exact nano)))))) (cons "ofInstant" (lambda (inst . _) (let ((ms (ms-of inst))) (jt-local-dt (jt-floor-div (exact (truncate ms)) 86400000) (* (jt-floor-mod (exact (truncate ms)) 86400000) 1000000))))) (cons "parse" (lambda (s . _) (call-with-values (lambda () (parse-iso-datetime (jt-str s))) (lambda (ed nod) (jt-local-dt ed nod))))) (cons "now" (lambda _ (let ((ms (exact (truncate (now-ms))))) (jt-local-dt (jt-floor-div ms 86400000) (* (jt-floor-mod ms 86400000) 1000000))))) (cons "from" (lambda (t) (cond ((and (jhost? t) (string=? (jhost-tag t) "local-date-time")) t) (else (let ((ms (ms-of t))) (jt-local-dt (jt-floor-div (exact (truncate ms)) 86400000) (* (jt-floor-mod (exact (truncate ms)) 86400000) 1000000))))))) (cons "MIN" ldt-min) (cons "MAX" ldt-max))) ;; date / time arithmetic on a LocalDateTime: round-trip through the components. (define (ldt-date x) (jt-local-date (ldt-epoch-day x))) (define (ldt-time x) (jt-local-time (ldt-nano-of-day x))) (define (ldt-combine d t) (jt-local-dt (ld-epoch-day d) (lt-nano-of-day t))) ;; add nanos to a LocalDateTime, carrying whole days into the date. (define (ldt-plus-nanos x nanos) (let* ((total (+ (ldt-nano-of-day x) nanos)) (carry (jt-floor-div total nanos-per-day)) (nod (jt-floor-mod total nanos-per-day))) (jt-local-dt (+ (ldt-epoch-day x) carry) nod))) (register-host-methods! "local-date-time" (list (cons "getYear" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day x))) (lambda (y m d) y)))) (cons "getMonthValue" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day x))) (lambda (y m d) m)))) (cons "getMonth" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day x))) (lambda (y m d) (make-jhost "month-enum" (vector m)))))) (cons "getDayOfMonth" (lambda (x) (call-with-values (lambda () (epoch-day->ymd (ldt-epoch-day x))) (lambda (y m d) d)))) (cons "getDayOfWeek" (lambda (x) (make-jhost "dow-enum" (vector (ld-dow (ldt-epoch-day x)))))) (cons "getDayOfYear" (lambda (x) (ld-day-of-year (ldt-epoch-day x)))) (cons "getHour" (lambda (x) (lt-hour (ldt-time x)))) (cons "getMinute" (lambda (x) (lt-minute (ldt-time x)))) (cons "getSecond" (lambda (x) (lt-second (ldt-time x)))) (cons "getNano" (lambda (x) (lt-nano (ldt-time x)))) (cons "toLocalDate" (lambda (x) (ldt-date x))) (cons "toLocalTime" (lambda (x) (ldt-time x))) (cons "toEpochSecond" (lambda (x . _) (ldt->epoch-second x))) (cons "plusDays" (lambda (x n) (jt-local-dt (+ (ldt-epoch-day x) (jt->exact n)) (ldt-nano-of-day x)))) (cons "minusDays" (lambda (x n) (jt-local-dt (- (ldt-epoch-day x) (jt->exact n)) (ldt-nano-of-day x)))) (cons "plusWeeks" (lambda (x n) (jt-local-dt (+ (ldt-epoch-day x) (* 7 (jt->exact n))) (ldt-nano-of-day x)))) (cons "minusWeeks" (lambda (x n) (jt-local-dt (- (ldt-epoch-day x) (* 7 (jt->exact n))) (ldt-nano-of-day x)))) (cons "plusMonths" (lambda (x n) (ldt-combine (ld-plus-months (ldt-date x) (jt->exact n)) (ldt-time x)))) (cons "minusMonths" (lambda (x n) (ldt-combine (ld-plus-months (ldt-date x) (- (jt->exact n))) (ldt-time x)))) (cons "plusYears" (lambda (x n) (ldt-combine (ld-plus-years (ldt-date x) (jt->exact n)) (ldt-time x)))) (cons "minusYears" (lambda (x n) (ldt-combine (ld-plus-years (ldt-date x) (- (jt->exact n))) (ldt-time x)))) (cons "plusHours" (lambda (x n) (ldt-plus-nanos x (* (jt->exact n) 3600 nanos-per-sec)))) (cons "minusHours" (lambda (x n) (ldt-plus-nanos x (- (* (jt->exact n) 3600 nanos-per-sec))))) (cons "plusMinutes" (lambda (x n) (ldt-plus-nanos x (* (jt->exact n) 60 nanos-per-sec)))) (cons "minusMinutes" (lambda (x n) (ldt-plus-nanos x (- (* (jt->exact n) 60 nanos-per-sec))))) (cons "plusSeconds" (lambda (x n) (ldt-plus-nanos x (* (jt->exact n) nanos-per-sec)))) (cons "minusSeconds" (lambda (x n) (ldt-plus-nanos x (- (* (jt->exact n) nanos-per-sec))))) (cons "plusNanos" (lambda (x n) (ldt-plus-nanos x (jt->exact n)))) (cons "minusNanos" (lambda (x n) (ldt-plus-nanos x (- (jt->exact n))))) (cons "withYear" (lambda (x v) (ldt-combine (ld-with-field (ldt-date x) 'year (jt->exact v)) (ldt-time x)))) (cons "withMonth" (lambda (x v) (ldt-combine (ld-with-field (ldt-date x) 'month (jt->exact v)) (ldt-time x)))) (cons "withDayOfMonth" (lambda (x v) (ldt-combine (ld-with-field (ldt-date x) 'day (jt->exact v)) (ldt-time x)))) (cons "withDayOfYear" (lambda (x v) (ldt-combine (ld-with-field (ldt-date x) 'day-of-year (jt->exact v)) (ldt-time x)))) (cons "withHour" (lambda (x v) (ldt-combine (ldt-date x) (lt-with (ldt-time x) 'hour (jt->exact v))))) (cons "withMinute" (lambda (x v) (ldt-combine (ldt-date x) (lt-with (ldt-time x) 'minute (jt->exact v))))) (cons "withSecond" (lambda (x v) (ldt-combine (ldt-date x) (lt-with (ldt-time x) 'second (jt->exact v))))) (cons "withNano" (lambda (x v) (ldt-combine (ldt-date x) (lt-with (ldt-time x) 'nano (jt->exact v))))) (cons "truncatedTo" (lambda (x u) (ldt-combine (ldt-date x) (lt-truncate (ldt-time x) u)))) (cons "isBefore" (lambda (x o) (ldtms x)))) (cons "atOffset" (lambda (x off) (mk-zoned (ldt->ms x)))) (cons "toInstant" (lambda (x . _) (mk-instant (ldt->ms x)))) (cons "toString" (lambda (x) (iso-datetime-str (ldt-epoch-day x) (ldt-nano-of-day x)))))) (define (ldt-cmp x o) (cond ((< (ldt-epoch-day x) (ldt-epoch-day o)) -1) ((> (ldt-epoch-day x) (ldt-epoch-day o)) 1) ((< (ldt-nano-of-day x) (ldt-nano-of-day o)) -1) ((> (ldt-nano-of-day x) (ldt-nano-of-day o)) 1) (else 0))) (define (ldtexact s) 1000))) ((s nano) (mk-instant (+ (* (jt->exact s) 1000) (quotient (jt->exact nano) 1000000)))))) (cons "EPOCH" (mk-instant 0)) ;; java.time Instant MIN/MAX are -1e9..1e9 yrs; the ms model can't hold those ;; exactly, so use the broadest range the ms layer represents safely. (cons "MIN" (mk-instant (* (ymd->epoch-day -999999999 1 1) 86400000))) (cons "MAX" (mk-instant (+ (* (ymd->epoch-day 999999999 12 31) 86400000) 86399999))))) (register-host-methods! "instant" (list (cons "getEpochSecond" (lambda (x) (jt-floor-div (exact (truncate (inst-ms x))) 1000))) (cons "getNano" (lambda (x) (* (jt-floor-mod (exact (truncate (inst-ms x))) 1000) 1000000))) (cons "plusMillis" (lambda (x n) (mk-instant (+ (inst-ms x) (jt->exact n))))) (cons "minusMillis" (lambda (x n) (mk-instant (- (inst-ms x) (jt->exact n))))) (cons "plusSeconds" (lambda (x n) (mk-instant (+ (inst-ms x) (* (jt->exact n) 1000))))) (cons "minusSeconds" (lambda (x n) (mk-instant (- (inst-ms x) (* (jt->exact n) 1000))))) (cons "plusNanos" (lambda (x n) (mk-instant (+ (inst-ms x) (quotient (jt->exact n) 1000000))))) (cons "minusNanos" (lambda (x n) (mk-instant (- (inst-ms x) (quotient (jt->exact n) 1000000))))) (cons "isBefore" (lambda (x o) (< (inst-ms x) (inst-ms o)))) (cons "isAfter" (lambda (x o) (> (inst-ms x) (inst-ms o)))) (cons "compareTo" (lambda (x o) (let ((a (inst-ms x)) (b (inst-ms o))) (cond ((< a b) -1) ((> a b) 1) (else 0))))) (cons "equals" (lambda (x o) (and (jhost? o) (string=? (jhost-tag o) "instant") (= (inst-ms x) (inst-ms o))))) (cons "hashCode" (lambda (x) (jt->exact (inst-ms x)))) (cons "truncatedTo" (lambda (x u) (let ((unit (chrono-unit-name u))) (mk-instant (* (quotient (exact (truncate (inst-ms x))) (cond ((and unit (string-ci=? unit "DAYS")) 86400000) ((and unit (string-ci=? unit "HOURS")) 3600000) ((and unit (string-ci=? unit "MINUTES")) 60000) ((and unit (string-ci=? unit "SECONDS")) 1000) (else 1))) (cond ((and unit (string-ci=? unit "DAYS")) 86400000) ((and unit (string-ci=? unit "HOURS")) 3600000) ((and unit (string-ci=? unit "MINUTES")) 60000) ((and unit (string-ci=? unit "SECONDS")) 1000) (else 1))))))) (cons "atOffset" (lambda (x off) (mk-zoned (inst-ms x)))) (cons "toString" (lambda (x) (iso-instant-str (inst-ms x)))))) ;; --- Month / DayOfWeek enums (returned by getMonth / getDayOfWeek) ----------- (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) (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) (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"))) (define (jt-time? x) (and (jhost? x) (string=? (jhost-tag x) "local-time"))) (define (jt-dt? x) (and (jhost? x) (string=? (jhost-tag x) "local-date-time"))) (register-eq-arm! (lambda (a b) (or (jt-date? a) (jt-date? b))) (lambda (a b) (and (jt-date? a) (jt-date? b) (= (ld-epoch-day a) (ld-epoch-day b))))) (register-hash-arm! jt-date? (lambda (x) (jolt-hash (ld-epoch-day x)))) (register-eq-arm! (lambda (a b) (or (jt-time? a) (jt-time? b))) (lambda (a b) (and (jt-time? a) (jt-time? b) (= (lt-nano-of-day a) (lt-nano-of-day b))))) (register-hash-arm! jt-time? (lambda (x) (jolt-hash (lt-nano-of-day x)))) (register-eq-arm! (lambda (a b) (or (jt-dt? a) (jt-dt? b))) (lambda (a b) (and (jt-dt? a) (jt-dt? b) (ldt=? a b)))) (register-hash-arm! jt-dt? (lambda (x) (jolt-hash (+ (* (ldt-epoch-day x) 31) (ldt-nano-of-day x))))) (register-str-render! jt-date? (lambda (x) (iso-date-str (ld-epoch-day x)))) (register-pr-arm! jt-date? (lambda (x) (iso-date-str (ld-epoch-day x)))) (register-str-render! jt-time? (lambda (x) (iso-time-str (lt-nano-of-day x)))) (register-pr-arm! jt-time? (lambda (x) (iso-time-str (lt-nano-of-day x)))) (register-str-render! jt-dt? (lambda (x) (iso-datetime-str (ldt-epoch-day x) (ldt-nano-of-day x)))) (register-pr-arm! jt-dt? (lambda (x) (iso-datetime-str (ldt-epoch-day x) (ldt-nano-of-day x)))) ;; the "instant" jhost prints as a java.time ISO instant (…Z), not the bare record. (define (jt-instant? x) (and (jhost? x) (string=? (jhost-tag x) "instant"))) (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 (lambda (a b) (cond ((and (jt-date? a) (jt-date? b)) (cond ((< (ld-epoch-day a) (ld-epoch-day b)) -1) ((> (ld-epoch-day a) (ld-epoch-day b)) 1) (else 0))) ((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"). (register-instance-check-arm! (lambda (type-sym val) (let ((tn (short-class-name (symbol-t-name type-sym)))) (cond ((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)))))