Migrate std/derive2 and std/text/csv to .ss
ober
0d1e194c481a075ec27e706fa5fc6e447a720b5c
deleted file mode 100644 --- a/lib/std/derive2.sls +++ /dev/null @@ -1,210 +0,0 @@ -#!chezscheme -;;; (std derive2) — Auto-derive v2: extensible protocol implementations -;;; -;;; Extends std/derive with more derivation strategies and user-defined protocols. -;;; -;;; API: -;;; (define-protocol name (method ...) ...) — define a derivable protocol -;;; (auto-equal rtd) — derive equal? for record type -;;; (auto-hash rtd) — derive hash for record type -;;; (auto-display rtd) — derive display for record type -;;; (auto-compare rtd) — derive comparison for record type -;;; (auto-clone rtd) — derive deep copy for record type -;;; (auto-serialize rtd) — derive serialize/deserialize -;;; (auto-json rtd) — derive ->json / json-> -;;; (derive-all rtd protocols) — derive multiple protocols - -(library (std derive2) - (export define-protocol auto-equal auto-hash auto-display - auto-compare auto-clone auto-serialize auto-json - derive-all protocol-registry register-protocol! - record-field-values record-field-names-of) - - (import (chezscheme)) - - ;; ========== Protocol registry ========== - - (define *protocols* (make-eq-hashtable)) - - (define (register-protocol! name deriver) - (hashtable-set! *protocols* name deriver)) - - (define (protocol-registry) *protocols*) - - ;; ========== Record introspection helpers ========== - ;; - ;; The parent-walk helpers below now route through Chez core primitives - ;; (record-fields / record->alist, Phase 72 — landed 2026-04-26). Where we - ;; only have an rtd (no instance), we still walk the chain locally because - ;; the core prims are instance-based. Local walk is parents-first to match - ;; the core contract. - - (define (rtd-chain rtd) - (let loop ([r rtd] [acc '()]) - (if r (loop (record-type-parent r) (cons r acc)) acc))) - - (define (record-field-names-of rtd) - (apply append - (map (lambda (r) (vector->list (record-type-field-names r))) - (rtd-chain rtd)))) - - (define (record-field-values obj) - ;; Chez core: parents-first list of (name . value) pairs. - (map cdr (record->alist obj))) - - (define (all-field-accessors rtd) - (apply append - (map (lambda (r) - (let ([n (vector-length (record-type-field-names r))]) - (let lp ([i 0] [acc '()]) - (if (fx= i n) - (reverse acc) - (lp (fx+ i 1) - (cons (record-accessor r i) acc)))))) - (rtd-chain rtd)))) - - ;; ========== auto-equal ========== - - (define (auto-equal rtd) - (let ([accessors (all-field-accessors rtd)] - [pred (record-predicate rtd)]) - (lambda (a b) - (and (pred a) (pred b) - (let loop ([accs accessors]) - (or (null? accs) - (and (equal? ((car accs) a) ((car accs) b)) - (loop (cdr accs))))))))) - - ;; ========== auto-hash ========== - - (define (auto-hash rtd) - (let ([accessors (all-field-accessors rtd)]) - (lambda (obj) - (let loop ([accs accessors] [h 0]) - (if (null? accs) - h - (loop (cdr accs) - (fxlogxor (fxarithmetic-shift-left h 5) - (equal-hash ((car accs) obj))))))))) - - ;; ========== auto-display ========== - - (define (auto-display rtd) - (let ([accessors (all-field-accessors rtd)] - [names (record-field-names-of rtd)] - [type-name (record-type-name rtd)]) - (lambda (obj port) - (display "#<" port) - (display type-name port) - (for-each - (lambda (name acc) - (display " " port) - (display name port) - (display "=" port) - (write (acc obj) port)) - names accessors) - (display ">" port)))) - - ;; ========== auto-compare ========== - - (define (auto-compare rtd) - (let ([accessors (all-field-accessors rtd)]) - (lambda (a b) - (let loop ([accs accessors]) - (if (null? accs) - 0 ;; equal - (let ([va ((car accs) a)] - [vb ((car accs) b)]) - (cond - [(and (number? va) (number? vb)) - (cond [(< va vb) -1] - [(> va vb) 1] - [else (loop (cdr accs))])] - [(and (string? va) (string? vb)) - (cond [(string<? va vb) -1] - [(string>? va vb) 1] - [else (loop (cdr accs))])] - [(and (symbol? va) (symbol? vb)) - (cond [(string<? (symbol->string va) (symbol->string vb)) -1] - [(string>? (symbol->string va) (symbol->string vb)) 1] - [else (loop (cdr accs))])] - [else (loop (cdr accs))]))))))) - - ;; ========== auto-clone ========== - - (define (auto-clone rtd) - (let ([accessors (all-field-accessors rtd)] - [constructor (record-constructor - (make-record-constructor-descriptor rtd #f #f))]) - (lambda (obj) - (apply constructor (map (lambda (acc) (acc obj)) accessors))))) - - ;; ========== auto-serialize ========== - - (define (auto-serialize rtd) - (let ([accessors (all-field-accessors rtd)] - [names (record-field-names-of rtd)] - [type-name (record-type-name rtd)] - [constructor (record-constructor - (make-record-constructor-descriptor rtd #f #f))]) - (cons - ;; serializer - (lambda (obj) - (cons type-name - (map (lambda (name acc) (cons name (acc obj))) - names accessors))) - ;; deserializer - (lambda (alist) - (apply constructor - (map (lambda (name) - (cdr (assq name (cdr alist)))) - names)))))) - - ;; ========== auto-json ========== - - (define (auto-json rtd) - (let ([accessors (all-field-accessors rtd)] - [names (record-field-names-of rtd)] - [constructor (record-constructor - (make-record-constructor-descriptor rtd #f #f))]) - (cons - ;; ->json (to alist) - (lambda (obj) - (map (lambda (name acc) - (cons (symbol->string name) (acc obj))) - names accessors)) - ;; json-> (from alist) - (lambda (alist) - (apply constructor - (map (lambda (name) - (cdr (or (assoc (symbol->string name) alist) - (cons "" #f)))) - names)))))) - - ;; ========== derive-all ========== - - (define (derive-all rtd protocols) - (map (lambda (proto) - (let ([deriver (hashtable-ref *protocols* proto #f)]) - (if deriver - (cons proto (deriver rtd)) - (cons proto - (case proto - [(equal) (auto-equal rtd)] - [(hash) (auto-hash rtd)] - [(display) (auto-display rtd)] - [(compare) (auto-compare rtd)] - [(clone) (auto-clone rtd)] - [(serialize) (auto-serialize rtd)] - [(json) (auto-json rtd)] - [else (error 'derive-all "unknown protocol" proto)]))))) - protocols)) - - ;; ========== define-protocol macro ========== - - (define-syntax define-protocol - (syntax-rules () - [(_ name deriver-expr) - (register-protocol! 'name deriver-expr)])) - -) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/derive2.ss @@ -0,0 +1,211 @@ +#!chezscheme +;;; (std derive2) — Auto-derive v2: extensible protocol implementations +;;; +;;; Extends std/derive with more derivation strategies and user-defined protocols. +;;; +;;; API: +;;; (define-protocol name (method ...) ...) — define a derivable protocol +;;; (auto-equal rtd) — derive equal? for record type +;;; (auto-hash rtd) — derive hash for record type +;;; (auto-display rtd) — derive display for record type +;;; (auto-compare rtd) — derive comparison for record type +;;; (auto-clone rtd) — derive deep copy for record type +;;; (auto-serialize rtd) — derive serialize/deserialize +;;; (auto-json rtd) — derive ->json / json-> +;;; (derive-all rtd protocols) — derive multiple protocols + +(library (std derive2) + (export define-protocol auto-equal auto-hash auto-display + auto-compare auto-clone auto-serialize auto-json + derive-all protocol-registry register-protocol! + record-field-values record-field-names-of) + + (import (chezscheme) + (only (jerboa core) def)) + + ;; ========== Protocol registry ========== + + (def *protocols* (make-eq-hashtable)) + + (def (register-protocol! name deriver) + (hashtable-set! *protocols* name deriver)) + + (def (protocol-registry) *protocols*) + + ;; ========== Record introspection helpers ========== + ;; + ;; The parent-walk helpers below now route through Chez core primitives + ;; (record-fields / record->alist, Phase 72 — landed 2026-04-26). Where we + ;; only have an rtd (no instance), we still walk the chain locally because + ;; the core prims are instance-based. Local walk is parents-first to match + ;; the core contract. + + (def (rtd-chain rtd) + (let loop ([r rtd] [acc '()]) + (if r (loop (record-type-parent r) (cons r acc)) acc))) + + (def (record-field-names-of rtd) + (apply append + (map (lambda (r) (vector->list (record-type-field-names r))) + (rtd-chain rtd)))) + + (def (record-field-values obj) + ;; Chez core: parents-first list of (name . value) pairs. + (map cdr (record->alist obj))) + + (def (all-field-accessors rtd) + (apply append + (map (lambda (r) + (let ([n (vector-length (record-type-field-names r))]) + (let lp ([i 0] [acc '()]) + (if (fx= i n) + (reverse acc) + (lp (fx+ i 1) + (cons (record-accessor r i) acc)))))) + (rtd-chain rtd)))) + + ;; ========== auto-equal ========== + + (def (auto-equal rtd) + (let ([accessors (all-field-accessors rtd)] + [pred (record-predicate rtd)]) + (lambda (a b) + (and (pred a) (pred b) + (let loop ([accs accessors]) + (or (null? accs) + (and (equal? ((car accs) a) ((car accs) b)) + (loop (cdr accs))))))))) + + ;; ========== auto-hash ========== + + (def (auto-hash rtd) + (let ([accessors (all-field-accessors rtd)]) + (lambda (obj) + (let loop ([accs accessors] [h 0]) + (if (null? accs) + h + (loop (cdr accs) + (fxlogxor (fxarithmetic-shift-left h 5) + (equal-hash ((car accs) obj))))))))) + + ;; ========== auto-display ========== + + (def (auto-display rtd) + (let ([accessors (all-field-accessors rtd)] + [names (record-field-names-of rtd)] + [type-name (record-type-name rtd)]) + (lambda (obj port) + (display "#<" port) + (display type-name port) + (for-each + (lambda (name acc) + (display " " port) + (display name port) + (display "=" port) + (write (acc obj) port)) + names accessors) + (display ">" port)))) + + ;; ========== auto-compare ========== + + (def (auto-compare rtd) + (let ([accessors (all-field-accessors rtd)]) + (lambda (a b) + (let loop ([accs accessors]) + (if (null? accs) + 0 ;; equal + (let ([va ((car accs) a)] + [vb ((car accs) b)]) + (cond + [(and (number? va) (number? vb)) + (cond [(< va vb) -1] + [(> va vb) 1] + [else (loop (cdr accs))])] + [(and (string? va) (string? vb)) + (cond [(string<? va vb) -1] + [(string>? va vb) 1] + [else (loop (cdr accs))])] + [(and (symbol? va) (symbol? vb)) + (cond [(string<? (symbol->string va) (symbol->string vb)) -1] + [(string>? (symbol->string va) (symbol->string vb)) 1] + [else (loop (cdr accs))])] + [else (loop (cdr accs))]))))))) + + ;; ========== auto-clone ========== + + (def (auto-clone rtd) + (let ([accessors (all-field-accessors rtd)] + [constructor (record-constructor + (make-record-constructor-descriptor rtd #f #f))]) + (lambda (obj) + (apply constructor (map (lambda (acc) (acc obj)) accessors))))) + + ;; ========== auto-serialize ========== + + (def (auto-serialize rtd) + (let ([accessors (all-field-accessors rtd)] + [names (record-field-names-of rtd)] + [type-name (record-type-name rtd)] + [constructor (record-constructor + (make-record-constructor-descriptor rtd #f #f))]) + (cons + ;; serializer + (lambda (obj) + (cons type-name + (map (lambda (name acc) (cons name (acc obj))) + names accessors))) + ;; deserializer + (lambda (alist) + (apply constructor + (map (lambda (name) + (cdr (assq name (cdr alist)))) + names)))))) + + ;; ========== auto-json ========== + + (def (auto-json rtd) + (let ([accessors (all-field-accessors rtd)] + [names (record-field-names-of rtd)] + [constructor (record-constructor + (make-record-constructor-descriptor rtd #f #f))]) + (cons + ;; ->json (to alist) + (lambda (obj) + (map (lambda (name acc) + (cons (symbol->string name) (acc obj))) + names accessors)) + ;; json-> (from alist) + (lambda (alist) + (apply constructor + (map (lambda (name) + (cdr (or (assoc (symbol->string name) alist) + (cons "" #f)))) + names)))))) + + ;; ========== derive-all ========== + + (def (derive-all rtd protocols) + (map (lambda (proto) + (let ([deriver (hashtable-ref *protocols* proto #f)]) + (if deriver + (cons proto (deriver rtd)) + (cons proto + (case proto + [(equal) (auto-equal rtd)] + [(hash) (auto-hash rtd)] + [(display) (auto-display rtd)] + [(compare) (auto-compare rtd)] + [(clone) (auto-clone rtd)] + [(serialize) (auto-serialize rtd)] + [(json) (auto-json rtd)] + [else (error 'derive-all "unknown protocol" proto)]))))) + protocols)) + + ;; ========== define-protocol macro ========== + + (define-syntax define-protocol + (syntax-rules () + [(_ name deriver-expr) + (register-protocol! 'name deriver-expr)])) + +) ;; end library deleted file mode 100644 --- a/lib/std/text/csv.sls +++ /dev/null @@ -1,125 +0,0 @@ -#!chezscheme -;;; :std/text/csv -- CSV parsing and writing - -(library (std text csv) - (export - read-csv - read-csv-records - write-csv - write-csv-record - csv-read - csv-write - *csv-strict-quotes* - *csv-max-field-length*) - - (import (chezscheme)) - - (define *csv-strict-quotes* (make-parameter #t)) - (define *csv-max-field-length* (make-parameter (* 1 1024 1024))) ;; 1MB default - - (define (read-csv port . rest) - ;; Read all CSV records from port - ;; Returns a list of lists of strings - (let ((separator (if (pair? rest) (car rest) #\,))) - (let lp ((records '())) - (let ((record (read-csv-record port separator))) - (if (not record) - (reverse records) - (lp (cons record records))))))) - - (define (read-csv-records port . rest) - (apply read-csv port rest)) - - (define (read-csv-record port . rest) - ;; Read a single CSV record (one line) from port - ;; Returns a list of strings, or #f at EOF - (let ((separator (if (pair? rest) (car rest) #\,))) - (let ((line (get-line port))) - (if (eof-object? line) - #f - (parse-csv-line line separator))))) - - (define (parse-csv-line line separator) - ;; Parse a CSV line into fields - (let ((len (string-length line))) - (let lp ((i 0) (fields '()) (current '())) - (cond - ((>= i len) - (reverse (cons (list->string (reverse current)) fields))) - ((char=? (string-ref line i) #\") - ;; Quoted field - (let lp2 ((j (+ i 1)) (chars '())) - (cond - ((>= j len) - (if (*csv-strict-quotes*) - (error 'parse-csv-line "unterminated quoted field") - (reverse (cons (list->string (reverse chars)) fields)))) - ((char=? (string-ref line j) #\") - (if (and (< (+ j 1) len) (char=? (string-ref line (+ j 1)) #\")) - ;; Escaped quote - (lp2 (+ j 2) (cons #\" chars)) - ;; End of quoted field - (let ((k (+ j 1))) - (if (or (>= k len) (char=? (string-ref line k) separator)) - (lp (+ k 1) (cons (list->string (reverse chars)) fields) '()) - (lp k fields (reverse chars)))))) - (else - (when (> (length chars) (*csv-max-field-length*)) - (error 'parse-csv-line "field exceeds maximum length" - (length chars) (*csv-max-field-length*))) - (lp2 (+ j 1) (cons (string-ref line j) chars)))))) - ((char=? (string-ref line i) separator) - (lp (+ i 1) (cons (list->string (reverse current)) fields) '())) - (else - (lp (+ i 1) fields (cons (string-ref line i) current))))))) - - (define (write-csv records port . rest) - ;; Write a list of records to port - (let ((separator (if (pair? rest) (car rest) #\,))) - (for-each - (lambda (record) - (write-csv-record record port separator)) - records))) - - (define (write-csv-record record port . rest) - ;; Write a single CSV record - (let ((separator (if (pair? rest) (car rest) #\,))) - (let lp ((fields record) (first? #t)) - (unless (null? fields) - (unless first? - (write-char separator port)) - (write-csv-field (car fields) port separator) - (lp (cdr fields) #f))) - (newline port))) - - (define (write-csv-field field port separator) - (let ((s (if (string? field) field (format "~a" field)))) - (if (or (string-contains? s (string separator)) - (string-contains? s "\"") - (string-contains? s "\n")) - ;; Quote the field - (begin - (write-char #\" port) - (string-for-each - (lambda (c) - (when (char=? c #\") - (write-char #\" port)) - (write-char c port)) - s) - (write-char #\" port)) - (display s port)))) - - (define (string-contains? s sub) - (let ((slen (string-length s)) - (sublen (string-length sub))) - (let lp ((i 0)) - (cond - ((> (+ i sublen) slen) #f) - ((string=? (substring s i (+ i sublen)) sub) #t) - (else (lp (+ i 1))))))) - - ;; Aliases - (define csv-read read-csv) - (define csv-write write-csv) - - ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/text/csv.ss @@ -0,0 +1,126 @@ +#!chezscheme +;;; :std/text/csv -- CSV parsing and writing + +(library (std text csv) + (export + read-csv + read-csv-records + write-csv + write-csv-record + csv-read + csv-write + *csv-strict-quotes* + *csv-max-field-length*) + + (import (chezscheme) + (only (jerboa core) def)) + + (def *csv-strict-quotes* (make-parameter #t)) + (def *csv-max-field-length* (make-parameter (* 1 1024 1024))) ;; 1MB default + + (def (read-csv port . rest) + ;; Read all CSV records from port + ;; Returns a list of lists of strings + (let ((separator (if (pair? rest) (car rest) #\,))) + (let lp ((records '())) + (let ((record (read-csv-record port separator))) + (if (not record) + (reverse records) + (lp (cons record records))))))) + + (def (read-csv-records port . rest) + (apply read-csv port rest)) + + (def (read-csv-record port . rest) + ;; Read a single CSV record (one line) from port + ;; Returns a list of strings, or #f at EOF + (let ((separator (if (pair? rest) (car rest) #\,))) + (let ((line (get-line port))) + (if (eof-object? line) + #f + (parse-csv-line line separator))))) + + (def (parse-csv-line line separator) + ;; Parse a CSV line into fields + (let ((len (string-length line))) + (let lp ((i 0) (fields '()) (current '())) + (cond + ((>= i len) + (reverse (cons (list->string (reverse current)) fields))) + ((char=? (string-ref line i) #\") + ;; Quoted field + (let lp2 ((j (+ i 1)) (chars '())) + (cond + ((>= j len) + (if (*csv-strict-quotes*) + (error 'parse-csv-line "unterminated quoted field") + (reverse (cons (list->string (reverse chars)) fields)))) + ((char=? (string-ref line j) #\") + (if (and (< (+ j 1) len) (char=? (string-ref line (+ j 1)) #\")) + ;; Escaped quote + (lp2 (+ j 2) (cons #\" chars)) + ;; End of quoted field + (let ((k (+ j 1))) + (if (or (>= k len) (char=? (string-ref line k) separator)) + (lp (+ k 1) (cons (list->string (reverse chars)) fields) '()) + (lp k fields (reverse chars)))))) + (else + (when (> (length chars) (*csv-max-field-length*)) + (error 'parse-csv-line "field exceeds maximum length" + (length chars) (*csv-max-field-length*))) + (lp2 (+ j 1) (cons (string-ref line j) chars)))))) + ((char=? (string-ref line i) separator) + (lp (+ i 1) (cons (list->string (reverse current)) fields) '())) + (else + (lp (+ i 1) fields (cons (string-ref line i) current))))))) + + (def (write-csv records port . rest) + ;; Write a list of records to port + (let ((separator (if (pair? rest) (car rest) #\,))) + (for-each + (lambda (record) + (write-csv-record record port separator)) + records))) + + (def (write-csv-record record port . rest) + ;; Write a single CSV record + (let ((separator (if (pair? rest) (car rest) #\,))) + (let lp ((fields record) (first? #t)) + (unless (null? fields) + (unless first? + (write-char separator port)) + (write-csv-field (car fields) port separator) + (lp (cdr fields) #f))) + (newline port))) + + (def (write-csv-field field port separator) + (let ((s (if (string? field) field (format "~a" field)))) + (if (or (string-contains? s (string separator)) + (string-contains? s "\"") + (string-contains? s "\n")) + ;; Quote the field + (begin + (write-char #\" port) + (string-for-each + (lambda (c) + (when (char=? c #\") + (write-char #\" port)) + (write-char c port)) + s) + (write-char #\" port)) + (display s port)))) + + (def (string-contains? s sub) + (let ((slen (string-length s)) + (sublen (string-length sub))) + (let lp ((i 0)) + (cond + ((> (+ i sublen) slen) #f) + ((string=? (substring s i (+ i sublen)) sub) #t) + (else (lp (+ i 1))))))) + + ;; Aliases + (def csv-read read-csv) + (def csv-write write-csv) + + ) ;; end library