Add token-saving macros, CSV module, and clean prelude
ober
f4f57a31b667a719e4a011840affe49c9e89d7b6
new file mode 100644 --- /dev/null +++ b/lib/std/csv.sls @@ -0,0 +1,183 @@ +#!chezscheme +;;; (std csv) — CSV reader/writer per RFC 4180 +;;; +;;; Handles: quoted fields, embedded commas, embedded newlines, +;;; escaped quotes (""), custom delimiters. + +(library (std csv) + (export + ;; Reading + read-csv read-csv-file csv-port->rows + ;; Writing + write-csv write-csv-file rows->csv-string + ;; Alist conversion + csv->alists alists->csv) + + (import (chezscheme)) + + ;; --- Reading --- + + ;; Read CSV string into list of rows (each row is a list of strings) + (define read-csv + (case-lambda + [(str) (read-csv str #\,)] + [(str delim) + (let ([port (open-input-string str)]) + (csv-port->rows port delim))])) + + ;; Read CSV file into list of rows + (define read-csv-file + (case-lambda + [(path) (read-csv-file path #\,)] + [(path delim) + (call-with-input-file path + (lambda (port) (csv-port->rows port delim)))])) + + ;; Read all rows from a port + (define csv-port->rows + (case-lambda + [(port) (csv-port->rows port #\,)] + [(port delim) + (let loop ([acc '()]) + (let ([row (read-csv-row port delim)]) + (if (eof-object? row) + (reverse acc) + (loop (cons row acc)))))])) + + ;; Read one CSV row from port, returns list of strings or eof + (define (read-csv-row port delim) + (let ([ch (peek-char port)]) + (if (eof-object? ch) + ch + (let loop ([fields '()] [current (open-output-string)] [in-quote? #f]) + (let ([c (read-char port)]) + (cond + ;; EOF + [(eof-object? c) + (reverse (cons (get-output-string current) fields))] + ;; Inside quoted field + [in-quote? + (cond + [(char=? c #\") + (let ([next (peek-char port)]) + (if (and (char? next) (char=? next #\")) + ;; Escaped quote "" + (begin (read-char port) + (write-char #\" current) + (loop fields current #t)) + ;; End of quoted field + (loop fields current #f)))] + [else + (write-char c current) + (loop fields current #t)])] + ;; Not in quote + [(char=? c #\") + (loop fields current #t)] + [(char=? c delim) + (loop (cons (get-output-string current) fields) + (open-output-string) #f)] + [(char=? c #\newline) + (reverse (cons (get-output-string current) fields))] + [(char=? c #\return) + ;; Skip CR, let LF end the row + (when (and (char? (peek-char port)) (char=? (peek-char port) #\newline)) + (read-char port)) + (reverse (cons (get-output-string current) fields))] + [else + (write-char c current) + (loop fields current #f)])))))) + + ;; --- Writing --- + + ;; Write rows to CSV string + (define rows->csv-string + (case-lambda + [(rows) (rows->csv-string rows #\,)] + [(rows delim) + (let ([port (open-output-string)]) + (write-csv-to-port rows port delim) + (get-output-string port))])) + + ;; Write rows to file + (define write-csv-file + (case-lambda + [(path rows) (write-csv-file path rows #\,)] + [(path rows delim) + (call-with-output-file path + (lambda (port) (write-csv-to-port rows port delim)) + 'replace)])) + + ;; Write rows to current-output-port or specified port + (define write-csv + (case-lambda + [(rows) (write-csv-to-port rows (current-output-port) #\,)] + [(rows port) (write-csv-to-port rows port #\,)] + [(rows port delim) (write-csv-to-port rows port delim)])) + + (define (write-csv-to-port rows port delim) + (for-each + (lambda (row) + (let loop ([fields row] [first? #t]) + (unless (null? fields) + (unless first? (write-char delim port)) + (write-csv-field (car fields) port delim) + (loop (cdr fields) #f))) + (display "\r\n" port)) ;; RFC 4180: CRLF + rows)) + + (define (write-csv-field val port delim) + (let ([s (if (string? val) val (format "~a" val))]) + (if (needs-quoting? s delim) + (begin + (write-char #\" port) + (string-for-each + (lambda (c) + (when (char=? c #\") (write-char #\" port)) ;; escape quotes + (write-char c port)) + s) + (write-char #\" port)) + (display s port)))) + + (define (needs-quoting? s delim) + (let ([len (string-length s)]) + (let loop ([i 0]) + (and (< i len) + (let ([c (string-ref s i)]) + (or (char=? c delim) + (char=? c #\") + (char=? c #\newline) + (char=? c #\return) + (loop (+ i 1)))))))) + + ;; --- Alist conversion --- + + ;; Convert CSV (with header row) to list of alists + ;; First row is treated as column names (symbols) + (define csv->alists + (case-lambda + [(str) (csv->alists str #\,)] + [(str delim) + (let ([rows (read-csv str delim)]) + (if (null? rows) '() + (let ([headers (map string->symbol (car rows))]) + (map (lambda (row) + (map cons headers row)) + (cdr rows)))))])) + + ;; Convert list of alists to CSV string (with header row) + (define alists->csv + (case-lambda + [(alists) (alists->csv alists #\,)] + [(alists delim) + (if (null? alists) "" + (let* ([headers (map car (car alists))] + [header-row (map symbol->string headers)] + [data-rows (map (lambda (al) + (map (lambda (h) + (let ([pair (assq h al)]) + (if pair (format "~a" (cdr pair)) ""))) + headers)) + alists)]) + (rows->csv-string (cons header-row data-rows) delim)))])) + + ) ;; end library --- a/lib/std/misc/string.sls +++ b/lib/std/misc/string.sls @@ -14,8 +14,11 @@ (export string-split string-join string-trim string-prefix? string-suffix? string-contains string-index - string-empty? string-trim-eol) - (import (chezscheme)) + string-empty? string-trim-eol + ;; Regex convenience + string-match? string-find string-find-all) + (import (chezscheme) + (std pregexp)) (define string-split (case-lambda @@ -123,4 +126,35 @@ (try-suffix "\r") str))) + ;; --- Regex convenience wrappers --- + + ;; string-match?: does the string match the pattern? + ;; (string-match? "^[0-9]+$" "12345") => #t + (define (string-match? pattern str) + (and (pregexp-match pattern str) #t)) + + ;; string-find: return first match or #f + ;; (string-find "[0-9]+" "abc 123 def") => "123" + ;; With groups: returns list of match + groups + (define (string-find pattern str) + (let ([m (pregexp-match pattern str)]) + (and m + (if (null? (cdr m)) + (car m) ;; no groups: return match string + m)))) ;; groups: return full match list + + ;; string-find-all: return all non-overlapping matches + ;; (string-find-all "[0-9]+" "a1b22c333") => ("1" "22" "333") + (define (string-find-all pattern str) + (let ([rx (pregexp pattern)]) + (let loop ([s str] [acc '()]) + (let ([m (pregexp-match-positions rx s)]) + (if (not m) + (reverse acc) + (let* ([start (caar m)] + [end (cdar m)] + [matched (substring s start end)] + [rest (substring s (max end (+ start 1)) (string-length s))]) + (loop rest (cons matched acc)))))))) + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/prelude.sls @@ -0,0 +1,216 @@ +#!chezscheme +;;; (std prelude) — One import for everything +;;; +;;; (import (std prelude)) gives you the full jerboa API plus +;;; all new libraries (result, datetime, threading, etc.) +;;; with all Chez Scheme conflicts pre-resolved. + +(library (std prelude) + (export + ;; ---- Core macros ---- + def def* defrule defrules + defstruct defclass defmethod + match match/strict + define-match-type define-sealed-hierarchy define-active-pattern + try catch finally + while until + + ;; hash constructors + hash-literal hash-eq-literal + let-hash + + ;; ---- Runtime ---- + ~ bind-method! call-method + make-hash-table make-hash-table-eq + hash-ref hash-get hash-put! hash-update! hash-remove! + hash-key? hash->list hash->plist hash-for-each hash-map hash-fold + hash-find hash-keys hash-values hash-copy hash-clear! + hash-merge hash-merge! hash-length hash-table? + list->hash-table plist->hash-table + keyword? keyword->string string->keyword make-keyword + error-message error-irritants error-trace + displayln 1+ 1- + iota last-pair + *method-tables* + register-struct-type! *struct-types* + struct-predicate struct-field-ref struct-field-set! + struct-type-info + + ;; ---- std/sort ---- + sort sort! stable-sort stable-sort! + + ;; ---- std/format ---- + format printf fprintf eprintf + + ;; ---- std/error ---- + Error ContractViolation + + ;; ---- std/sugar ---- + chain chain-and assert! + -> ->> as-> some-> some->> cond-> cond->> + ->? ->>? + awhen aif when-let if-let + cut cute <> <...> + dotimes + with-resource + str + alist + defn + defrecord + let-alist + define-enum + capture + + ;; ---- std/text/json ---- + read-json write-json json-object->string string->json-object + + ;; ---- std/os/path ---- + path-expand path-normalize path-directory path-strip-directory + path-extension path-strip-extension + path-join path-absolute? + + ;; ---- std/misc/string ---- + string-split string-join string-trim + string-prefix? string-suffix? + string-contains string-index + string-empty? + string-match? string-find string-find-all + + ;; ---- std/misc/list ---- + flatten unique snoc + take drop + every any + filter-map + group-by + zip + frequencies + partition partition-all partition-by + interleave interpose + mapcat + distinct + keep + some + iterate-n + reductions + take-last drop-last + split-at split-with + + ;; ---- std/misc/alist ---- + agetq agetv aget + asetq! asetv! aset! + pgetq pgetv pget + alist->hash-table + + ;; ---- std/misc/ports ---- + read-all-as-string read-all-as-lines + read-file-string read-file-lines + write-file-string + with-input-from-string with-output-to-string + + ;; ---- std/misc/func ---- + compose compose1 identity constantly flip + curry curryn negate conjoin disjoin + memo-proc juxt + partial complement comp + fnil every-pred some-fn + + ;; ---- std/iter ---- + for for/collect for/fold for/or for/and + in-list in-vector in-range in-string + in-hash-keys in-hash-values in-hash-pairs + in-naturals in-indexed + in-port in-lines in-chars in-bytes in-producer + + ;; ---- std/result ---- + ok err + ok? err? result? + unwrap unwrap-err unwrap-or unwrap-or-else + map-ok map-err + and-then or-else + flatten-result + result->values + try-result try-result* + result->option + results-partition + map-results + filter-ok filter-err + sequence-results + ok->list err->list + + ;; ---- std/datetime ---- + make-datetime datetime? + make-date make-time + datetime-now datetime-utc-now + datetime-year datetime-month datetime-day + datetime-hour datetime-minute datetime-second + datetime-nanosecond datetime-offset + parse-datetime parse-date parse-time + datetime->string date->string time->string + datetime->iso8601 + datetime->epoch epoch->datetime + datetime->julian julian->datetime + datetime-add datetime-subtract + datetime-diff + duration duration? duration-seconds duration-nanoseconds + make-duration + datetime<? datetime>? datetime=? datetime<=? datetime>=? + datetime-min datetime-max datetime-clamp + day-of-week day-of-year days-in-month leap-year? + datetime->alist + datetime-truncate + datetime-floor-hour datetime-floor-day datetime-floor-month + + ;; ---- std/debug/pp ---- + pp pp-to-string pprint + ppd ppd-to-string + + ;; ---- std/csv ---- + read-csv read-csv-file csv-port->rows + write-csv write-csv-file rows->csv-string + csv->alists alists->csv + + ;; ---- FFI ---- + c-lambda define-c-lambda + begin-ffi c-declare) + + (import + (except (chezscheme) + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1- + partition + make-date make-time) + (only (jerboa core) + def def* defrule defrules + defstruct defclass defmethod + try catch finally + while until + hash-literal hash-eq-literal + let-hash) + (only (std match2) + match match/strict + define-match-type define-sealed-hierarchy define-active-pattern) + (jerboa runtime) + (jerboa ffi) + (std sort) + (std format) + (except (std error) error-message error-irritants error-trace error? + with-exception-handler) + (except (std sugar) try catch finally) + (std text json) + (std os path) + (std misc string) + (std misc list) + (std misc alist) + (std misc ports) + (std misc func) + (std iter) + (std result) + (std datetime) + (std debug pp) + (std csv)) + + ) ;; end library --- a/lib/std/sugar.sls +++ b/lib/std/sugar.sls @@ -17,6 +17,24 @@ when-let if-let ;; Clojure-style threading -> ->> as-> some-> some->> cond-> cond->> + ;; Result-aware threading + ->? ->>? + ;; Resource management + with-resource + ;; String builder + str + ;; Alist constructor + alist + ;; Guarded definitions + defn + ;; Record shorthand + defrecord + ;; Alist destructuring + let-alist + ;; Enum definitions + define-enum + ;; Output capture + capture ;; Iteration dotimes ;; Multiple value binding (re-export from Chez) @@ -25,7 +43,8 @@ make-hash-table hash-table? iota 1+ 1- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) - (jerboa core)) + (jerboa core) + (std result)) ;; chain: thread a value through a series of expressions ;; (chain val (f _ arg) (g arg _)) → (g arg (f val arg)) @@ -299,4 +318,220 @@ (let ([v val]) (cond->> (if test (->> v form) v) rest ...))])) + ;; --- Result-aware threading macros --- + + ;; ->? : thread through ok values as first arg, short-circuit on err + ;; (->? (ok 5) (+ 1) (* 2)) => (ok 12) + ;; (->? (err "bad") (+ 1)) => (err "bad") + (define-syntax ->? + (syntax-rules () + [(_ val) val] + [(_ val (f args ...) rest ...) + (let ([v val]) + (if (err? v) + v + (->? (ok (f (unwrap v) args ...)) rest ...)))] + [(_ val f rest ...) + (->? val (f) rest ...)])) + + ;; ->>? : thread through ok values as last arg, short-circuit on err + (define-syntax ->>? + (syntax-rules () + [(_ val) val] + [(_ val (f args ...) rest ...) + (let ([v val]) + (if (err? v) + v + (->>? (ok (f args ... (unwrap v))) rest ...)))] + [(_ val f rest ...) + (->>? val (f) rest ...)])) + + ;; --- Resource management --- + + ;; with-resource: automatic open/close lifecycle + ;; (with-resource (p (open-input-file "foo.txt") close-input-port) (read p)) + (define-syntax with-resource + (syntax-rules () + [(_ (var init cleanup) body body* ...) + (let ([var init]) + (dynamic-wind + (lambda () (void)) + (lambda () body body* ...) + (lambda () (cleanup var))))])) + + ;; --- String builder --- + + ;; str: concatenate args, auto-coercing to strings + ;; (str "hello " 42 " world") => "hello 42 world" + ;; (str) => "" + (define-syntax str + (syntax-rules () + [(_) ""] + [(_ arg args ...) + (string-append (->string arg) (->string args) ...)])) + + (define (->string x) + (cond + [(string? x) x] + [(number? x) (number->string x)] + [(symbol? x) (symbol->string x)] + [(char? x) (string x)] + [(boolean? x) (if x "#t" "#f")] + [else (format "~a" x)])) + + ;; --- Alist constructor --- + + ;; alist: shorthand for building association lists + ;; (alist (name "Alice") (age 30)) => ((name . "Alice") (age . 30)) + (define-syntax alist + (syntax-rules () + [(_ (key val) ...) + (list (cons 'key val) ...)])) + + ;; --- Guarded definitions --- + + ;; defn: define with inline type guards + ;; (defn (add [x number?] [y number?]) (+ x y)) + ;; Expands to: (define (add x y) (unless (number? x) (error ...)) (unless (number? y) (error ...)) (+ x y)) + (define-syntax defn + (syntax-rules () + [(_ (name [var pred] ...) body body* ...) + (define (name var ...) + (unless (pred var) + (error 'name (format "~a failed guard ~a, got ~s" 'var 'pred var))) ... + body body* ...)])) + + ;; --- Record shorthand --- + + ;; defrecord: define a record type with auto-generated accessors and printer + ;; (defrecord point (x y)) + ;; Generates: + ;; - make-point constructor + ;; - point? predicate + ;; - point-x, point-y accessors + ;; - (point->alist p) => ((x . val) (y . val)) + ;; - record-writer for readable printing + ;; defrecord delegates to defrecord-base (syntax-rules for clean record def) + ;; then defrecord-extras (syntax-case for generated names) + (define-syntax defrecord + (syntax-rules () + [(_ name (field ...)) + (begin + (define-record-type name + (fields field ...)) + (defrecord-extras name (field ...)))])) + + (define-syntax defrecord-extras + (lambda (stx) + (define (make-id ctx fmt . args) + (datum->syntax ctx + (string->symbol (apply format fmt args)))) + (syntax-case stx () + [(_ name (field ...)) + (let* ([name-str (symbol->string (syntax->datum #'name))] + [fields (syntax->list #'(field ...))]) + (with-syntax + ([alist-name (make-id #'name "~a->alist" name-str)] + [(accessor ...) + (map (lambda (f) + (make-id #'name "~a-~a" name-str + (symbol->string (syntax->datum f)))) + fields)] + [name-string (datum->syntax #'name name-str)]) + #'(begin + (define (alist-name r) + (list (cons 'field (accessor r)) ...)) + (record-writer (record-type-descriptor name) + (lambda (r port writer) + (display "#<" port) + (display name-string port) + (begin + (display " " port) + (display 'field port) + (display "=" port) + (writer (accessor r) port)) ... + (display ">" port))) + )))]))) ;; close: begin, with-syntax, let*, branch, syntax-case, lambda, define-syntax + + ;; --- Alist destructuring --- + + ;; let-alist: destructure an alist into bindings + ;; (let-alist expr ([name n] [age a]) body ...) + ;; binds n to (cdr (assq 'name expr)), a to (cdr (assq 'age expr)) + ;; (let-alist expr (name age) body ...) + ;; binds name and age directly from alist keys + (define-syntax let-alist + (syntax-rules () + ;; Named bindings: [key var] + [(_ alist-expr ([key var] ...) body body* ...) + (let ([al alist-expr]) + (let ([var (cdr (assq 'key al))] ...) + body body* ...))] + ;; Short form: use field names as variable names + [(_ alist-expr (key ...) body body* ...) + (let ([al alist-expr]) + (let ([key (cdr (assq 'key al))] ...) + body body* ...))])) + + ;; --- Enum definitions --- + + ;; define-enum: define a set of named integer constants with lookups + ;; (define-enum color (red green blue)) + ;; Generates: + ;; - color-red => 0, color-green => 1, color-blue => 2 + ;; - color? predicate (checks if value is valid) + ;; - color->name: value => symbol + ;; - name->color: symbol => value + (define-syntax define-enum + (lambda (stx) + (syntax-case stx () + [(_ name (val ...)) + (let* ([name-str (symbol->string (syntax->datum #'name))] + [vals (map syntax->datum (syntax->list #'(val ...)))] + [n (length vals)] + [mk-id (lambda (fmt) + (datum->syntax #'name + (string->symbol (format fmt name-str))))] + [const-ids (map (lambda (v) + (datum->syntax #'name + (string->symbol + (format "~a-~a" name-str (symbol->string v))))) + vals)] + [indices (let loop ([i 0] [acc '()]) + (if (= i n) (reverse acc) + (loop (+ i 1) (cons i acc))))]) + (with-syntax ([pred (mk-id "~a?")] + [to-name (mk-id "~a->name")] + [from-name (mk-id "name->~a")] + [(const-id ...) const-ids] + [(idx ...) (map (lambda (i) (datum->syntax #'name i)) indices)] + [(val-sym ...) (map (lambda (v) (datum->syntax #'name `(quote ,v))) vals)] + [max-val (datum->syntax #'name (- n 1))]) + #'(begin + (define const-id idx) ... + (define (pred v) (and (integer? v) (>= v 0) (<= v max-val))) + (define to-name + (let ([names (vector val-sym ...)]) + (lambda (v) + (if (pred v) (vector-ref names v) + (error 'to-name "invalid enum value" v))))) + (define from-name + (let ([pairs (list (cons val-sym idx) ...)]) + (lambda (sym) + (cond + [(assq sym pairs) => cdr] + [else (error 'from-name "unknown enum name" sym)])))))))]))) + + ;; --- Output capture --- + + ;; capture: capture stdout output as a string + ;; (capture (display "hello") (display " world")) => "hello world" + (define-syntax capture + (syntax-rules () + [(_ body body* ...) + (let ([p (open-output-string)]) + (parameterize ([current-output-port p]) + body body* ...) + (get-output-string p))])) + ) ;; end library --- a/lib/std/test/framework.sls +++ b/lib/std/test/framework.sls @@ -11,6 +11,8 @@ arbitrary-integer arbitrary-string arbitrary-list arbitrary-boolean ;; Test assertions test-case test-equal test-not-equal test-true test-false test-error + ;; Quick-check assertions (minimal boilerplate) + check= check-true check-false check-pred check-error ;; State/config *test-suites* with-test-output) @@ -269,4 +271,59 @@ (record-pass! name) (record-fail! name (format "falsified with values: ~s" result)))))])) + ;; --- Quick-check assertions (auto-named from expression) --- + ;; These eliminate the need for explicit test names. + ;; (check= (+ 1 2) 3) instead of (test-equal "add" (+ 1 2) 3) + + (define-syntax check= + (syntax-rules () + [(_ actual expected) + (guard (exn [#t (record-error! (format "~s" 'actual) exn)]) + (let ([got actual] [exp expected]) + (if (equal? got exp) + (record-pass! (format "~s" 'actual)) + (record-fail! (format "~s" 'actual) + (format "got ~s, expected ~s" got exp)))))])) + + (define-syntax check-true + (syntax-rules () + [(_ expr) + (guard (exn [#t (record-error! (format "~s" 'expr) exn)]) + (let ([v expr]) + (if v + (record-pass! (format "~s" 'expr)) + (record-fail! (format "~s" 'expr) + (format "expected truthy, got ~s" v)))))])) + + (define-syntax check-false + (syntax-rules () + [(_ expr) + (guard (exn [#t (record-error! (format "~s" 'expr) exn)]) + (let ([v expr]) + (if (not v) + (record-pass! (format "~s" 'expr)) + (record-fail! (format "~s" 'expr) + (format "expected #f, got ~s" v)))))])) + + (define-syntax check-pred + (syntax-rules () + [(_ pred expr) + (guard (exn [#t (record-error! (format "~s" 'expr) exn)]) + (let ([v expr]) + (if (pred v) + (record-pass! (format "~s" 'expr)) + (record-fail! (format "~s" 'expr) + (format "~s did not satisfy ~s" v 'pred)))))])) + + (define-syntax check-error + (syntax-rules () + [(_ expr) + (let ([raised? #f]) + (guard (exn [#t (set! raised? #t)]) + expr) + (if raised? + (record-pass! (format "~s" 'expr)) + (record-fail! (format "~s" 'expr) + "expected an error, none raised")))])) + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-cycle-savers.ss @@ -0,0 +1,206 @@ +#!chezscheme +(import (except (chezscheme) make-date make-time partition + make-hash-table hash-table? + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string + iota 1+ 1-) + (std sugar) + (std result) + (std misc string) + (std csv)) + +(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))))])) + +(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))])))) + +;; ========== defrecord ========== + +(display "--- defrecord ---") (newline) + +(defrecord point (x y)) + +;; Constructor +(let ([p (make-point 3 4)]) + ;; Predicate + (chk (point? p) => #t) + (chk (point? 42) => #f) + ;; Accessors + (chk (point-x p) => 3) + (chk (point-y p) => 4) + ;; ->alist + (chk (point->alist p) => '((x . 3) (y . 4)))) + +;; Printer +(let* ([p (make-point 10 20)] + [s (let ([port (open-output-string)]) + (write p port) + (get-output-string port))]) + (chk (string-contains* s "point") => #t) + (chk (string-contains* s "x=") => #t) + (chk (string-contains* s "10") => #t)) + +;; Multi-field record +(defrecord person (name age email)) +(let ([p (make-person "Alice" 30 "alice@example.com")]) + (chk (person? p) => #t) + (chk (person-name p) => "Alice") + (chk (person-age p) => 30) + (chk (person-email p) => "alice@example.com") + (chk (length (person->alist p)) => 3)) + +;; ========== let-alist ========== + +(display "--- let-alist ---") (newline) + +;; Named bindings +(let-alist '((name . "Alice") (age . 30)) + ([name n] [age a]) + (chk n => "Alice") + (chk a => 30)) + +;; Short form (field names as variable names) +(let-alist '((x . 1) (y . 2) (z . 3)) + (x y z) + (chk (+ x y z) => 6)) + +;; ========== define-enum ========== + +(display "--- define-enum ---") (newline) + +(define-enum color (red green blue)) + +(chk color-red => 0) +(chk color-green => 1) +(chk color-blue => 2) + +;; Predicate +(chk (color? 0) => #t) +(chk (color? 2) => #t) +(chk (color? 3) => #f) +(chk (color? -1) => #f) + +;; Name lookup +(chk (color->name 0) => 'red) +(chk (color->name 1) => 'green) +(chk (color->name 2) => 'blue) + +;; Reverse lookup +(chk (name->color 'red) => 0) +(chk (name->color 'blue) => 2) + +;; ========== capture ========== + +(display "--- capture ---") (newline) + +(chk (capture (display "hello")) => "hello") +(chk (capture (display "a") (display "b") (display "c")) => "abc") +(chk (capture (write 42)) => "42") +(chk (capture (void)) => "") + +;; Nested capture doesn't leak +(let ([outer (capture + (display "outer:") + (let ([inner (capture (display "inner"))]) + (display inner)))]) + (chk outer => "outer:inner")) + +;; ========== string-match? / string-find / string-find-all ========== + +(display "--- regex convenience ---") (newline) + +;; string-match? +(chk (string-match? "^[0-9]+$" "12345") => #t) +(chk (string-match? "^[0-9]+$" "abc") => #f) +(chk (string-match? "hello" "say hello world") => #t) + +;; string-find +(chk (string-find "[0-9]+" "abc 123 def") => "123") +(chk (string-find "[0-9]+" "no numbers here") => #f) + +;; string-find with groups +(let ([m (string-find "([a-z]+)=([0-9]+)" "key=42")]) + (chk (car m) => "key=42") + (chk (cadr m) => "key") + (chk (caddr m) => "42")) + +;; string-find-all +(chk (string-find-all "[0-9]+" "a1b22c333") => '("1" "22" "333")) +(chk (string-find-all "[a-z]+" "123") => '()) +(chk (string-find-all "\\w+" "hello world foo") => '("hello" "world" "foo")) + +;; ========== CSV ========== + +(display "--- CSV ---") (newline) + +;; Basic reading +(let ([rows (read-csv "a,b,c\n1,2,3\n4,5,6\n")]) + (chk (length rows) => 3) + (chk (car rows) => '("a" "b" "c")) + (chk (cadr rows) => '("1" "2" "3"))) + +;; Quoted fields +(let ([rows (read-csv "name,desc\nAlice,\"has a, comma\"\n")]) + (chk (length rows) => 2) + (chk (cadr rows) => '("Alice" "has a, comma"))) + +;; Escaped quotes +(let ([rows (read-csv "val\n\"she said \"\"hi\"\"\"\n")]) + (chk (cadr rows) => '("she said \"hi\""))) + +;; Writing +(let ([s (rows->csv-string '(("a" "b") ("1" "2")))]) + (chk (string-contains* s "a,b") => #t) + (chk (string-contains* s "1,2") => #t)) + +;; Write with quoting +(let ([s (rows->csv-string '(("has,comma" "normal")))]) + (chk (string-contains* s "\"has,comma\"") => #t)) + +;; csv->alists +(let ([als (csv->alists "name,age\nAlice,30\nBob,25\n")]) + (chk (length als) => 2) + (chk (cdr (assq 'name (car als))) => "Alice") + (chk (cdr (assq 'age (cadr als))) => "25")) + +;; alists->csv roundtrip +(let* ([data (csv->alists "x,y\n1,2\n3,4\n")] + [csv-str (alists->csv data)] + [data2 (csv->alists csv-str)]) + (chk (length data2) => 2) + (chk (cdr (assq 'x (car data2))) => "1")) + +;; Custom delimiter (TSV) +(let ([rows (read-csv "a\tb\n1\t2\n" #\tab)]) + (chk (car rows) => '("a" "b")) + (chk (cadr rows) => '("1" "2"))) + +;; Empty input +(chk (read-csv "") => '()) + +;; ========== Summary ========== + +(newline) +(display "cycle-savers: ") +(display pass) (display " passed, ") +(display fail) (display " failed") (newline) +(when (> fail 0) (exit 1)) new file mode 100644 --- /dev/null +++ b/tests/test-prelude.ss @@ -0,0 +1,79 @@ +#!chezscheme +(import (std prelude)) + +(define pass 0) +(define fail 0) +(define-syntax chk + (syntax-rules (=>) + [(_ expr => expected)