Add Result type, datetime library, and enhanced pretty-printer
ober
22aa7b15df93824adbc1311dcc909659d0d97ce5
new file mode 100644 --- /dev/null +++ b/lib/std/datetime.sls @@ -0,0 +1,389 @@ +#!chezscheme +;;; (std datetime) — Date/time handling for data pipelines +;;; +;;; Pure Scheme implementation with ISO 8601 support. +;;; Dates are stored as records with year/month/day/hour/minute/second/nanosecond/offset. +;;; Designed for parsing timestamps from data sources (CSV, Parquet, databases). + +(library (std datetime) + (export + ;; Constructors + make-datetime datetime? + make-date make-time + datetime-now datetime-utc-now + ;; Accessors + datetime-year datetime-month datetime-day + datetime-hour datetime-minute datetime-second + datetime-nanosecond datetime-offset + ;; Parsing + parse-datetime parse-date parse-time + ;; Formatting + datetime->string date->string time->string + datetime->iso8601 + ;; Conversion + datetime->epoch epoch->datetime + datetime->julian julian->datetime + ;; Arithmetic + datetime-add datetime-subtract + datetime-diff + duration duration? duration-seconds duration-nanoseconds + make-duration + ;; Comparison + datetime<? datetime>? datetime=? datetime<=? datetime>=? + datetime-min datetime-max datetime-clamp + ;; Components + day-of-week day-of-year days-in-month leap-year? + ;; Utilities + datetime->alist + datetime-truncate + datetime-floor-hour datetime-floor-day datetime-floor-month) + + (import (except (chezscheme) make-date make-time)) + + ;; --- Records --- + + (define-record-type dt + (fields year month day hour minute second nanosecond offset) + (protocol + (lambda (new) + (case-lambda + [(y m d) (new y m d 0 0 0 0 0)] + [(y m d h mi s) (new y m d h mi s 0 0)] + [(y m d h mi s ns) (new y m d h mi s ns 0)] + [(y m d h mi s ns off) (new y m d h mi s ns off)])))) + + (define (datetime? x) (dt? x)) + + (define (make-datetime y m d . rest) + (apply make-dt y m d rest)) + + (define (make-date y m d) + (make-dt y m d 0 0 0 0 0)) + + (define (make-time h m s) + (make-dt 0 0 0 h m s 0 0)) + + ;; Accessors + (define datetime-year dt-year) + (define datetime-month dt-month) + (define datetime-day dt-day) + (define datetime-hour dt-hour) + (define datetime-minute dt-minute) + (define datetime-second dt-second) + (define datetime-nanosecond dt-nanosecond) + (define datetime-offset dt-offset) + + ;; --- Current time --- + + (define (datetime-now) + (let ([t (current-time 'time-utc)]) + (epoch->datetime (time-second t)))) + + (define datetime-utc-now datetime-now) + + ;; --- Epoch conversion --- + + ;; Seconds since 1970-01-01T00:00:00Z + (define (datetime->epoch dt) + (let* ([y (dt-year dt)] + [m (dt-month dt)] + [d (dt-day dt)] + [jd (date->julian-day y m d)] + [epoch-jd (date->julian-day 1970 1 1)] + [days (- jd epoch-jd)] + [secs (+ (* days 86400) + (* (dt-hour dt) 3600) + (* (dt-minute dt) 60) + (dt-second dt) + (- (* (dt-offset dt) 60)))]) ;; offset is minutes from UTC + secs)) + + (define (epoch->datetime secs) + (let* ([days (floor (/ secs 86400))] + [rem (- secs (* days 86400))] + [rem (if (< rem 0) (begin (set! days (- days 1)) (+ rem 86400)) rem)] + [h (floor (/ rem 3600))] + [rem (- rem (* h 3600))] + [mi (floor (/ rem 60))] + [s (- rem (* mi 60))]) + (let-values ([(y m d) (julian-day->date (+ (date->julian-day 1970 1 1) days))]) + (make-dt (exact y) (exact m) (exact d) + (exact h) (exact mi) (exact s) 0 0)))) + + ;; --- Julian day helpers --- + + (define (date->julian-day y m d) + (let* ([a (quotient (- 14 m) 12)] + [y1 (+ y 4800 (- a))] + [m1 (+ m (* 12 a) -3)]) + (+ d + (quotient (+ (* 153 m1) 2) 5) + (* 365 y1) + (quotient y1 4) + (- (quotient y1 100)) + (quotient y1 400) + -32045))) + + (define (julian-day->date jd) + (let* ([a (+ jd 32044)] + [b (quotient (+ (* 4 a) 3) 146097)] + [c (- a (quotient (* 146097 b) 4))] + [d (quotient (+ (* 4 c) 3) 1461)] + [e (- c (quotient (* 1461 d) 4))] + [m (quotient (+ (* 5 e) 2) 153)] + [day (+ e (- (quotient (+ (* 153 m) 2) 5)) 1)] + [month (+ m 3 (- (* 12 (quotient m 10))))] + [year (+ (* 100 b) d -4800 (quotient m 10))]) + (values year month day))) + + (define datetime->julian + (lambda (dt) + (date->julian-day (dt-year dt) (dt-month dt) (dt-day dt)))) + + (define julian->datetime + (lambda (jd) + (let-values ([(y m d) (julian-day->date jd)]) + (make-dt y m d 0 0 0 0 0)))) + + ;; --- Parsing --- + + ;; Parse ISO 8601: "2024-03-25T10:30:00Z" or "2024-03-25T10:30:00+05:30" + ;; Also handles: "2024-03-25", "2024-03-25 10:30:00", "2024-03-25T10:30:00.123456789Z" + (define (parse-datetime str) + (let ([len (string-length str)]) + (when (< len 10) + (error 'parse-datetime "string too short" str)) + (let* ([year (string->number (substring str 0 4))] + [month (string->number (substring str 5 7))] + [day (string->number (substring str 8 10))]) + (unless (and year month day) + (error 'parse-datetime "invalid date components" str)) + (if (<= len 10) + (make-dt year month day 0 0 0 0 0) + ;; Has time component + (let ([sep-pos 10]) + (unless (or (char=? (string-ref str sep-pos) #\T) + (char=? (string-ref str sep-pos) #\t) + (char=? (string-ref str sep-pos) #\space)) + (error 'parse-datetime "expected T or space separator" str)) + (when (< len 19) + (error 'parse-datetime "incomplete time" str)) + (let* ([hour (string->number (substring str 11 13))] + [minute (string->number (substring str 14 16))] + [second (string->number (substring str 17 19))]) + (unless (and hour minute second) + (error 'parse-datetime "invalid time components" str)) + ;; Check for fractional seconds + (let-values ([(ns rest-pos) + (if (and (> len 19) (char=? (string-ref str 19) #\.)) + (parse-fractional str 20) + (values 0 19))]) + ;; Check for timezone + (let ([offset (parse-tz-offset str rest-pos len)]) + (make-dt year month day hour minute second ns offset))))))))) + + ;; Parse fractional seconds, return (values nanoseconds end-position) + (define (parse-fractional str start) + (let loop ([i start] [digits '()]) + (if (and (< i (string-length str)) + (char<=? #\0 (string-ref str i)) + (char<=? (string-ref str i) #\9)) + (loop (+ i 1) (cons (string-ref str i) digits)) + (let* ([digit-str (list->string (reverse digits))] + ;; Pad to 9 digits for nanoseconds + [padded (string-append digit-str + (make-string (max 0 (- 9 (length digits))) #\0))] + [ns (string->number (substring padded 0 9))]) + (values (or ns 0) i))))) + + ;; Parse timezone offset from position, return offset in minutes + (define (parse-tz-offset str pos len) + (cond + [(>= pos len) 0] + [(char=? (string-ref str pos) #\Z) 0] + [(char=? (string-ref str pos) #\z) 0] + [(or (char=? (string-ref str pos) #\+) + (char=? (string-ref str pos) #\-)) + (let* ([sign (if (char=? (string-ref str pos) #\+) 1 -1)] + [tz-str (substring str (+ pos 1) len)] + [tz-h (string->number (substring tz-str 0 2))] + [tz-m (if (> (string-length tz-str) 2) + (string->number (substring tz-str + (if (char=? (string-ref tz-str 2) #\:) 3 2) + (min (string-length tz-str) + (if (char=? (string-ref tz-str 2) #\:) 5 4)))) + 0)]) + (* sign (+ (* (or tz-h 0) 60) (or tz-m 0))))] + [else 0])) + + (define (parse-date str) + (parse-datetime str)) + + (define (parse-time str) + ;; Parse "HH:MM:SS" or "HH:MM:SS.nnn" + (parse-datetime (string-append "0000-01-01T" str))) + + ;; --- Formatting --- + + (define (pad2 n) + (if (< n 10) + (string-append "0" (number->string n)) + (number->string n))) + + (define (pad4 n) + (cond + [(< n 10) (string-append "000" (number->string n))] + [(< n 100) (string-append "00" (number->string n))] + [(< n 1000) (string-append "0" (number->string n))] + [else (number->string n)])) + + (define (datetime->iso8601 d) + (let ([base (string-append + (pad4 (dt-year d)) "-" + (pad2 (dt-month d)) "-" + (pad2 (dt-day d)) "T" + (pad2 (dt-hour d)) ":" + (pad2 (dt-minute d)) ":" + (pad2 (dt-second d)))]) + (let ([with-ns (if (> (dt-nanosecond d) 0) + (string-append base "." + (let ([s (number->string (dt-nanosecond d))]) + (string-append (make-string (- 9 (string-length s)) #\0) s))) + base)]) + (cond + [(= (dt-offset d) 0) (string-append with-ns "Z")] + [else + (let* ([abs-off (abs (dt-offset d))] + [sign (if (>= (dt-offset d) 0) "+" "-")] + [h (quotient abs-off 60)] + [m (remainder abs-off 60)]) + (string-append with-ns sign (pad2 h) ":" (pad2 m)))])))) + + (define (datetime->string d) + (datetime->iso8601 d)) + + (define (date->string d) + (string-append (pad4 (dt-year d)) "-" + (pad2 (dt-month d)) "-" + (pad2 (dt-day d)))) + + (define (time->string d) + (string-append (pad2 (dt-hour d)) ":" + (pad2 (dt-minute d)) ":" + (pad2 (dt-second d)))) + + ;; --- Duration --- + + (define-record-type dur + (fields seconds nanoseconds)) + + (define (duration? x) (dur? x)) + (define duration-seconds dur-seconds) + (define duration-nanoseconds dur-nanoseconds) + + (define make-duration + (case-lambda + [(secs) (make-dur secs 0)] + [(secs ns) (make-dur secs ns)])) + + (define duration make-duration) + + ;; --- Arithmetic --- + + ;; Add a duration (or seconds) to a datetime + (define datetime-add + (case-lambda + [(d secs) (datetime-add d secs 0)] + [(d secs ns) + (let* ([total-ns (+ (dt-nanosecond d) ns)] + [carry-s (quotient total-ns 1000000000)] + [new-ns (remainder total-ns 1000000000)] + [epoch (+ (datetime->epoch d) secs carry-s)]) + (let ([base (epoch->datetime epoch)]) + (make-dt (dt-year base) (dt-month base) (dt-day base) + (dt-hour base) (dt-minute base) (dt-second base) + new-ns (dt-offset d))))])) + + ;; Subtract seconds from a datetime + (define datetime-subtract + (case-lambda + [(d secs) (datetime-add d (- secs))] + [(d secs ns) (datetime-add d (- secs) (- ns))])) + + ;; Difference between two datetimes in seconds + (define (datetime-diff d1 d2) + (- (datetime->epoch d1) (datetime->epoch d2))) + + ;; --- Comparison --- + + (define (datetime<? a b) (< (datetime->epoch a) (datetime->epoch b))) + (define (datetime>? a b) (> (datetime->epoch a) (datetime->epoch b))) + (define (datetime=? a b) (= (datetime->epoch a) (datetime->epoch b))) + (define (datetime<=? a b) (<= (datetime->epoch a) (datetime->epoch b))) + (define (datetime>=? a b) (>= (datetime->epoch a) (datetime->epoch b))) + + (define (datetime-min a b) (if (datetime<? a b) a b)) + (define (datetime-max a b) (if (datetime>? a b) a b)) + + (define (datetime-clamp d lo hi) + (datetime-min (datetime-max d lo) hi)) + + ;; --- Calendar utilities --- + + (define (leap-year? y) + (or (and (zero? (mod y 4)) (not (zero? (mod y 100)))) + (zero? (mod y 400)))) + + (define (days-in-month y m) + (case m + [(1 3 5 7 8 10 12) 31] + [(4 6 9 11) 30] + [(2) (if (leap-year? y) 29 28)] + [else (error 'days-in-month "invalid month" m)])) + + ;; 0=Sunday, 1=Monday, ..., 6=Saturday (Zeller's formula) + (define (day-of-week y m d) + (let* ([jd (date->julian-day y m d)]) + (mod (+ jd 1) 7))) + + (define (day-of-year y m d) + (let loop ([i 1] [total 0]) + (if (= i m) (+ total d) + (loop (+ i 1) (+ total (days-in-month y i)))))) + + ;; --- Utilities --- + + (define (datetime->alist d) + (list (cons 'year (dt-year d)) + (cons 'month (dt-month d)) + (cons 'day (dt-day d)) + (cons 'hour (dt-hour d)) + (cons 'minute (dt-minute d)) + (cons 'second (dt-second d)) + (cons 'nanosecond (dt-nanosecond d)) + (cons 'offset (dt-offset d)))) + + ;; Truncate to given precision + (define (datetime-truncate d precision) + (case precision + [(year) (make-dt (dt-year d) 1 1 0 0 0 0 (dt-offset d))] + [(month) (make-dt (dt-year d) (dt-month d) 1 0 0 0 0 (dt-offset d))] + [(day) (make-dt (dt-year d) (dt-month d) (dt-day d) 0 0 0 0 (dt-offset d))] + [(hour) (make-dt (dt-year d) (dt-month d) (dt-day d) + (dt-hour d) 0 0 0 (dt-offset d))] + [(minute) (make-dt (dt-year d) (dt-month d) (dt-day d) + (dt-hour d) (dt-minute d) 0 0 (dt-offset d))] + [(second) (make-dt (dt-year d) (dt-month d) (dt-day d) + (dt-hour d) (dt-minute d) (dt-second d) 0 (dt-offset d))] + [else (error 'datetime-truncate "invalid precision" precision)])) + + (define (datetime-floor-hour d) + (datetime-truncate d 'hour)) + + (define (datetime-floor-day d) + (datetime-truncate d 'day)) + + (define (datetime-floor-month d) + (datetime-truncate d 'month)) + + ) ;; end library --- a/lib/std/debug/pp.sls +++ b/lib/std/debug/pp.sls @@ -1,15 +1,18 @@ #!chezscheme -;;; (std debug pp) — Pretty printer +;;; (std debug pp) — Pretty printer for data structures ;;; -;;; Expose Chez's pretty printer with Gerbil-compatible API. +;;; Extends Chez's pretty-print to handle hash tables, alists, records, +;;; and nested data structures with proper indentation. (library (std debug pp) (export pp pp-to-string pprint - pretty-print-columns) + pretty-print-columns + ;; Data-aware pretty printing + ppd ppd-to-string) (import (chezscheme)) - ;; pp: pretty-print to current output or specified port + ;; pp: pretty-print to current output or specified port (S-expressions) (define pp (case-lambda [(obj) (pretty-print obj)] @@ -25,8 +28,175 @@ (define pprint pp) ;; pretty-print-columns: re-export Chez parameter - ;; (pretty-line-length) gets/sets the print width - ;; We alias for Gerbil compatibility (define pretty-print-columns pretty-line-length) + ;; --- Data-aware pretty printing --- + ;; Handles: hash tables, alists, vectors, records, nested structures + + (define ppd + (case-lambda + [(obj) (ppd-print obj (current-output-port) 0) (newline)] + [(obj port) (ppd-print obj port 0) (newline port)])) + + (define (ppd-to-string obj) + (let ([port (open-output-string)]) + (ppd-print obj port 0) + (get-output-string port))) + + ;; Max depth to prevent infinite recursion on cyclic structures + (define *max-depth* 20) + + (define (ppd-print obj port indent) + (cond + ;; Hash table + [(hashtable? obj) + (ppd-hashtable obj port indent)] + ;; Association list (list of pairs with symbol/string keys) + [(alist? obj) + (ppd-alist obj port indent)] + ;; Vector + [(vector? obj) + (ppd-vector obj port indent)] + ;; List (non-alist) + [(and (pair? obj) (list? obj)) + (ppd-list obj port indent)] + ;; Everything else: use write + [else + (write obj port)])) + + ;; Detect alist: non-empty list of pairs with symbol or string keys + (define (alist? obj) + (and (pair? obj) + (list? obj) + (not (null? obj)) + (for-all (lambda (entry) + (and (pair? entry) + (or (symbol? (car entry)) + (string? (car entry))))) + obj))) + + ;; Pretty-print hash table + (define (ppd-hashtable ht port indent) + (let-values ([(keys vals) (hashtable-entries ht)]) + (let ([n (vector-length keys)]) + (if (= n 0) + (display "{}" port) + (begin + (display "{" port) + (let loop ([i 0]) + (when (< i n) + (when (> i 0) + (display "," port) + (newline port) + (indent! port (+ indent 1))) + (when (= i 0) + (newline port) + (indent! port (+ indent 1))) + (write (vector-ref keys i) port) + (display ": " port) + (ppd-print (vector-ref vals i) port (+ indent 1)) + (loop (+ i 1)))) + (newline port) + (indent! port indent) + (display "}" port)))))) + + ;; Pretty-print alist + (define (ppd-alist lst port indent) + (if (null? lst) + (display "{}" port) + (let ([compact? (and (<= (length lst) 4) + (for-all (lambda (e) (simple-value? (cdr e))) lst))]) + (if compact? + ;; Single-line for small, simple alists + (begin + (display "{" port) + (let loop ([rest lst] [first? #t]) + (unless (null? rest) + (unless first? (display ", " port)) + (write (caar rest) port) + (display ": " port) + (write (cdar rest) port) + (loop (cdr rest) #f))) + (display "}" port)) + ;; Multi-line + (begin + (display "{" port) + (let loop ([rest lst] [first? #t]) + (unless (null? rest) + (if first? + (begin (newline port) (indent! port (+ indent 1))) + (begin (display "," port) (newline port) (indent! port (+ indent 1)))) + (write (caar rest) port) + (display ": " port) + (ppd-print (cdar rest) port (+ indent 1)) + (loop (cdr rest) #f))) + (newline port) + (indent! port indent) + (display "}" port)))))) + + ;; Pretty-print vector + (define (ppd-vector vec port indent) + (let ([n (vector-length vec)]) + (if (and (<= n 8) (vector-all-simple? vec)) + ;; Compact single-line for small simple vectors + (begin + (display "#(" port) + (let loop ([i 0]) + (when (< i n) + (when (> i 0) (display " " port)) + (write (vector-ref vec i) port) + (loop (+ i 1)))) + (display ")" port)) + ;; Multi-line + (begin + (display "#(" port) + (let loop ([i 0]) + (when (< i n) + (when (> i 0) + (newline port) + (indent! port (+ indent 2))) + (when (= i 0) + (newline port) + (indent! port (+ indent 2))) + (ppd-print (vector-ref vec i) port (+ indent 2)) + (loop (+ i 1)))) + (display ")" port))))) + + ;; Pretty-print list + (define (ppd-list lst port indent) + (if (and (<= (length lst) 8) (for-all simple-value? lst)) + ;; Compact + (write lst port) + ;; Multi-line + (begin + (display "(" port) + (let loop ([rest lst] [first? #t]) + (unless (null? rest) + (if first? + (ppd-print (car rest) port (+ indent 1)) + (begin + (newline port) + (indent! port (+ indent 1)) + (ppd-print (car rest) port (+ indent 1)))) + (loop (cdr rest) #f))) + (display ")" port)))) + + ;; --- Helpers --- + + (define (indent! port n) + (let loop ([i 0]) + (when (< i (* n 2)) + (display #\space port) + (loop (+ i 1))))) + + (define (simple-value? v) + (or (number? v) (string? v) (symbol? v) (boolean? v) + (null? v) (char? v) (eq? v (void)))) + + (define (vector-all-simple? vec) + (let loop ([i 0]) + (or (= i (vector-length vec)) + (and (simple-value? (vector-ref vec i)) + (loop (+ i 1)))))) + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/result.sls @@ -0,0 +1,189 @@ +#!chezscheme +;;; (std result) — Result/Either monad for composable error handling +;;; +;;; Inspired by Rust's Result<T,E> and Clojure's approach to error values. +;;; Provides ok/err constructors, predicates, and combinators for +;;; building error-handling pipelines without exceptions. + +(library (std result) + (export + ;; Constructors + ok err + ;; Predicates + ok? err? result? + ;; Accessors + unwrap unwrap-err unwrap-or unwrap-or-else + ;; Mapping / chaining + map-ok map-err + and-then or-else + flatten-result + ;; Conversion + result->values + try-result try-result* + result->option + ;; Collection operations + results-partition + map-results + filter-ok filter-err + sequence-results + ;; Utilities + ok->list err->list) + + (import (chezscheme)) + + ;; --- Records --- + + (define-record-type result-ok (fields value)) + (define-record-type result-err (fields value)) + + ;; --- Constructors --- + + (define (ok v) (make-result-ok v)) + (define (err e) (make-result-err e)) + + ;; --- Predicates --- + + (define (ok? r) (result-ok? r)) + (define (err? r) (result-err? r)) + (define (result? r) (or (result-ok? r) (result-err? r))) + + ;; --- Accessors --- + + ;; Unwrap ok value or raise error + (define (unwrap r) + (if (ok? r) + (result-ok-value r) + (error 'unwrap "called unwrap on err" (result-err-value r)))) + + ;; Unwrap err value or raise error + (define (unwrap-err r) + (if (err? r) + (result-err-value r) + (error 'unwrap-err "called unwrap-err on ok" (result-ok-value r)))) + + ;; Unwrap ok value or return default + (define (unwrap-or r default) + (if (ok? r) (result-ok-value r) default)) + + ;; Unwrap ok value or call thunk for default + (define (unwrap-or-else r thunk) + (if (ok? r) (result-ok-value r) (thunk))) + + ;; --- Mapping / Chaining --- + + ;; Apply f to ok value, leave err untouched + (define (map-ok f r) + (if (ok? r) + (ok (f (result-ok-value r))) + r)) + + ;; Apply f to err value, leave ok untouched + (define (map-err f r) + (if (err? r) + (err (f (result-err-value r))) + r)) + + ;; Monadic bind: f must return a result + ;; (and-then (ok 5) (lambda (x) (ok (* x 2)))) => (ok 10) + ;; (and-then (err "bad") (lambda (x) (ok (* x 2)))) => (err "bad") + (define (and-then r f) + (if (ok? r) + (f (result-ok-value r)) + r)) + + ;; Try alternative on error + ;; (or-else (err "bad") (lambda (e) (ok 0))) => (ok 0) + (define (or-else r f) + (if (err? r) + (f (result-err-value r)) + r)) + + ;; Flatten nested results: (ok (ok x)) => (ok x) + (define (flatten-result r) + (if (and (ok? r) (result? (result-ok-value r))) + (result-ok-value r) + r)) + + ;; --- Conversion --- + + ;; Convert result to values: (values value-or-#f error-or-#f) + (define (result->values r) + (if (ok? r) + (values (result-ok-value r) #f) + (values #f (result-err-value r)))) + + ;; Wrap an expression that might throw — catches exceptions as err + ;; (try-result (/ 1 0)) => (err <condition>) + (define-syntax try-result + (syntax-rules () + [(_ body) + (guard (exn [#t (err exn)]) + (ok body))])) + + ;; try-result* — wrap body, convert exception message to string err + (define-syntax try-result* + (syntax-rules () + [(_ body) + (guard (exn + [#t (err (if (message-condition? exn) + (condition-message exn) + (format "~a" exn)))]) + (ok body))])) + + ;; Convert to option: ok -> value, err -> #f + (define (result->option r) + (if (ok? r) (result-ok-value r) #f)) + + ;; --- Collection Operations --- + + ;; Partition a list of results into (ok-values . err-values) + (define (results-partition results) + (let loop ([rest results] [oks '()] [errs '()]) + (if (null? rest) + (cons (reverse oks) (reverse errs)) + (let ([r (car rest)]) + (if (ok? r) + (loop (cdr rest) (cons (result-ok-value r) oks) errs) + (loop (cdr rest) oks (cons (result-err-value r) errs))))))) + + ;; Map a function that returns results, collect all + (define (map-results f lst) + (map f lst)) + + ;; Keep only ok values + (define (filter-ok results) + (let loop ([rest results] [acc '()]) + (if (null? rest) (reverse acc) + (if (ok? (car rest)) + (loop (cdr rest) (cons (result-ok-value (car rest)) acc)) + (loop (cdr rest) acc))))) + + ;; Keep only err values + (define (filter-err results) + (let loop ([rest results] [acc '()]) + (if (null? rest) (reverse acc) + (if (err? (car rest)) + (loop (cdr rest) (cons (result-err-value (car rest)) acc)) + (loop (cdr rest) acc))))) + + ;; Collect list of results into result of list + ;; All must be ok, or returns first err + (define (sequence-results results) + (let loop ([rest results] [acc '()]) + (cond + [(null? rest) (ok (reverse acc))] + [(ok? (car rest)) + (loop (cdr rest) (cons (result-ok-value (car rest)) acc))] + [else (car rest)]))) ;; return first err + + ;; --- Utilities --- + + ;; ok -> (value), err -> () + (define (ok->list r) + (if (ok? r) (list (result-ok-value r)) '())) + + ;; err -> (value), ok -> () + (define (err->list r) + (if (err? r) (list (result-err-value r)) '())) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-new-features.ss @@ -0,0 +1,242 @@ +#!chezscheme +(import (except (chezscheme) make-date make-time) + (std result) + (std datetime) + (std debug pp)) + +(define pass 0) +(define fail 0) +(define-syntax chk + (syntax-rules (=>) + [(_ expr => expected) + (let ([r expr] [e expected]) + (if (equal? r e) + (set! pass (+ pass 1)) + (begin (set! fail (+ fail 1)) + (display "FAIL: ") (write 'expr) + (display " => ") (write r) + (display " expected ") (write e) (newline))))])) + +;; Helper +(define (string-contains s sub) + (let ([slen (string-length s)] + [sublen (string-length sub)]) + (let loop ([i 0]) + (cond + [(> (+ i sublen) slen) #f] + [(string=? (substring s i (+ i sublen)) sub) #t] + [else (loop (+ i 1))])))) + +;; ========== Result type ========== + +(display "--- Result type ---") (newline) + +;; Constructors and predicates +(chk (ok? (ok 42)) => #t) +(chk (err? (err "bad")) => #t) +(chk (result? (ok 1)) => #t) +(chk (result? "hello") => #f) + +;; Unwrap +(chk (unwrap (ok 42)) => 42) +(chk (unwrap-err (err "bad")) => "bad") +(chk (unwrap-or (ok 42) 0) => 42) +(chk (unwrap-or (err "bad") 0) => 0) +(chk (unwrap-or-else (err "bad") (lambda () 99)) => 99) + +;; Mapping +(chk (unwrap (map-ok add1 (ok 5))) => 6) +(chk (err? (map-ok add1 (err "bad"))) => #t) +(chk (unwrap-err (map-err string-upcase (err "bad"))) => "BAD") +(chk (ok? (map-err string-upcase (ok 5))) => #t) + +;; Chaining +(chk (unwrap (and-then (ok 5) (lambda (x) (ok (* x 2))))) => 10) +(chk (err? (and-then (err "bad") (lambda (x) (ok (* x 2))))) => #t) +(chk (unwrap (or-else (err "bad") (lambda (e) (ok 0)))) => 0) +(chk (unwrap (or-else (ok 5) (lambda (e) (ok 0)))) => 5) + +;; Flatten +(chk (unwrap (flatten-result (ok (ok 42)))) => 42) +(chk (unwrap (flatten-result (ok 42))) => 42) + +;; try-result +(chk (ok? (try-result (+ 1 2))) => #t) +(chk (unwrap (try-result (+ 1 2))) => 3) +(chk (err? (try-result (error 'test "boom"))) => #t) + +;; Collection operations +(let ([results (list (ok 1) (err "a") (ok 2) (err "b"))]) + (let ([p (results-partition results)]) + (chk (car p) => '(1 2)) + (chk (cdr p) => '("a" "b"))) + (chk (filter-ok results) => '(1 2)) + (chk (filter-err results) => '("a" "b"))) + +(chk (unwrap (sequence-results (list (ok 1) (ok 2) (ok 3)))) => '(1 2 3)) +(chk (err? (sequence-results (list (ok 1) (err "bad") (ok 3)))) => #t) + +;; result->option +(chk (result->option (ok 42)) => 42) +(chk (result->option (err "bad")) => #f) + +;; ok->list / err->list +(chk (ok->list (ok 42)) => '(42)) +(chk (ok->list (err "bad")) => '()) +(chk (err->list (err "bad")) => '("bad")) + +;; ========== DateTime ========== + +(display "--- DateTime ---") (newline) + +;; Construction +(let ([d (make-datetime 2024 3 25 10 30 0)]) + (chk (datetime-year d) => 2024) + (chk (datetime-month d) => 3) + (chk (datetime-day d) => 25) + (chk (datetime-hour d) => 10) + (chk (datetime-minute d) => 30) + (chk (datetime-second d) => 0)) + +;; make-date +(let ([d (make-date 2024 12 31)]) + (chk (datetime-year d) => 2024) + (chk (datetime-hour d) => 0)) + +;; Parsing ISO 8601 +(let ([d (parse-datetime "2024-03-25T10:30:00Z")]) + (chk (datetime-year d) => 2024) + (chk (datetime-month d) => 3) + (chk (datetime-day d) => 25) + (chk (datetime-hour d) => 10) + (chk (datetime-minute d) => 30) + (chk (datetime-offset d) => 0)) + +;; Parse date only +(let ([d (parse-datetime "2024-03-25")]) + (chk (datetime-year d) => 2024) + (chk (datetime-hour d) => 0)) + +;; Parse with positive timezone offset +(let ([d (parse-datetime "2024-03-25T10:30:00+05:30")]) + (chk (datetime-hour d) => 10) + (chk (datetime-offset d) => 330)) + +;; Parse with negative offset +(let ([d (parse-datetime "2024-03-25T10:30:00-04:00")]) + (chk (datetime-offset d) => -240)) + +;; Formatting +(let ([d (make-datetime 2024 3 25 10 30 0)]) + (chk (datetime->iso8601 d) => "2024-03-25T10:30:00Z") + (chk (date->string d) => "2024-03-25") + (chk (time->string d) => "10:30:00")) + +;; Roundtrip: parse -> format -> parse +(let* ([s "2024-03-25T10:30:00Z"] + [d (parse-datetime s)] + [s2 (datetime->iso8601 d)]) + (chk s2 => s)) + +;; Epoch conversion roundtrip +(let* ([d (make-datetime 2024 3 25 10 30 0)] + [epoch (datetime->epoch d)] + [d2 (epoch->datetime epoch)]) + (chk (datetime-year d2) => 2024) + (chk (datetime-month d2) => 3) + (chk (datetime-day d2) => 25) + (chk (datetime-hour d2) => 10) + (chk (datetime-minute d2) => 30)) + +;; Unix epoch +(let ([d (epoch->datetime 0)]) + (chk (datetime-year d) => 1970) + (chk (datetime-month d) => 1) + (chk (datetime-day d) => 1)) + +;; Arithmetic +(let* ([d (make-datetime 2024 3 25 10 0 0)] + [d2 (datetime-add d 3600)]) ;; +1 hour + (chk (datetime-hour d2) => 11)) + +(let* ([d (make-datetime 2024 3 25 23 0 0)] + [d2 (datetime-add d 7200)]) ;; +2 hours, crosses midnight + (chk (datetime-day d2) => 26) + (chk (datetime-hour d2) => 1)) + +;; Diff +(let ([d1 (make-datetime 2024 3 25 10 0 0)] + [d2 (make-datetime 2024 3 25 11 0 0)]) + (chk (datetime-diff d2 d1) => 3600)) + +;; Comparison +(let ([d1 (make-datetime 2024 3 25)] + [d2 (make-datetime 2024 3 26)]) + (chk (datetime<? d1 d2) => #t) + (chk (datetime>? d2 d1) => #t) + (chk (datetime=? d1 d1) => #t)) + +;; Calendar utilities +(chk (leap-year? 2024) => #t) +(chk (leap-year? 2023) => #f) +(chk (leap-year? 2000) => #t) +(chk (leap-year? 1900) => #f) + +(chk (days-in-month 2024 2) => 29) +(chk (days-in-month 2023 2) => 28) +(chk (days-in-month 2024 1) => 31) + +;; day-of-year +(chk (day-of-year 2024 1 1) => 1) +(chk (day-of-year 2024 12 31) => 366) ;; leap year + +;; Truncation +(let ([d (make-datetime 2024 3 25 10 30 45)]) + (chk (datetime-hour (datetime-floor-day d)) => 0) + (chk (datetime-minute (datetime-floor-hour d)) => 0) + (chk (datetime-day (datetime-floor-month d)) => 1)) + +;; datetime->alist +(let ([d (make-datetime 2024 3 25)]) + (chk (cdr (assq 'year (datetime->alist d))) => 2024) + (chk (cdr (assq 'month (datetime->alist d))) => 3)) + +;; datetime-now returns a valid datetime +(let ([now (datetime-now)]) + (chk (>= (datetime-year now) 2024) => #t)) + +;; ========== Pretty printer ========== + +(display "--- Pretty printer (ppd) ---") (newline) + +;; Simple values +(chk (ppd-to-string 42) => "42")