Add list-builder, number, uri, walist, values, and assert modules
ober
94d3e327b65cf039905516c06646dd6f87c55522
new file mode 100644 --- /dev/null +++ b/lib/std/assert.sls @@ -0,0 +1,47 @@ +#!chezscheme +;;; :std/assert -- Assertion library + +(library (std assert) + (export assert! + assert-equal! + assert-pred + assert-exception) + (import (chezscheme)) + + ;; (assert! expr) or (assert! expr "message") + ;; Raises an error with the expression text if expr is #f. + (define-syntax assert! + (syntax-rules () + [(_ expr) + (unless expr + (error 'assert! (format "assertion failed: ~s" 'expr)))] + [(_ expr msg) + (unless expr + (error 'assert! (format "assertion failed: ~a (~s)" msg 'expr)))])) + + ;; (assert-equal! actual expected) + ;; Compare with equal?, raise error showing both values on mismatch. + (define (assert-equal! actual expected) + (unless (equal? actual expected) + (error 'assert-equal! + (format "expected ~s, got ~s" expected actual)))) + + ;; (assert-pred pred val) + ;; Assert that (pred val) is true. + (define (assert-pred pred val) + (unless (pred val) + (error 'assert-pred + (format "predicate ~s failed for value ~s" pred val)))) + + ;; (assert-exception thunk) + ;; Assert that thunk raises an exception. Returns the raised condition. + (define (assert-exception thunk) + (let ([result (guard (e [#t (cons 'caught e)]) + (thunk) + '(no-exception))]) + (if (and (pair? result) (eq? (car result) 'caught)) + (cdr result) + (error 'assert-exception + "expected an exception but none was raised")))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/list-builder.sls @@ -0,0 +1,50 @@ +#!chezscheme +;;; (std misc list-builder) — Efficient list accumulation macro +;;; +;;; Provides with-list-builder, which eliminates the reverse-accumulator +;;; pattern that litters imperative Scheme code. +;;; +;;; Usage: +;;; (with-list-builder (push!) +;;; (for-each (lambda (x) +;;; (when (> x 3) (push! x))) +;;; '(1 5 2 7 3 8))) +;;; ; => (5 7 8) +;;; +;;; The push! function appends to the end in O(1) using a tail pointer, +;;; so the result is in insertion order without needing reverse. + +(library (std misc list-builder) + (export with-list-builder) + + (import (chezscheme)) + + ;; with-list-builder: bind a push! function that builds a list in order. + ;; Uses a sentinel head node + tail pointer for O(1) append. + (define-syntax with-list-builder + (syntax-rules () + [(_ (push!)) + '()] + [(_ (push!) body body* ...) + (let* ([head (list 'sentinel)] + [tail head]) + (define (push! val) + (let ([new-pair (list val)]) + (set-cdr! tail new-pair) + (set! tail new-pair))) + body body* ... + (cdr head))] + ;; Two-arg form: (with-list-builder (push! peek) body ...) + ;; peek returns the list built so far + [(_ (push! peek) body body* ...) + (let* ([head (list 'sentinel)] + [tail head]) + (define (push! val) + (let ([new-pair (list val)]) + (set-cdr! tail new-pair) + (set! tail new-pair))) + (define (peek) (cdr head)) + body body* ... + (cdr head))])) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/number.sls @@ -0,0 +1,63 @@ +#!chezscheme +;;; :std/misc/number -- Number utilities + +(library (std misc number) + (export natural? + positive-integer? + negative? + clamp + divmod + number->padded-string + number->human-readable + integer-length* + fixnum->flonum) + (import (chezscheme)) + + (define (natural? x) + (and (integer? x) (exact? x) (>= x 0))) + + (define (positive-integer? x) + (and (integer? x) (exact? x) (> x 0))) + + (define (clamp x lo hi) + (cond [(< x lo) lo] + [(> x hi) hi] + [else x])) + + (define (divmod n d) + (values (quotient n d) (remainder n d))) + + (define number->padded-string + (case-lambda + ((n width) (number->padded-string n width 10)) + ((n width base) + (let* ((s (string-downcase (number->string (abs n) base))) + (len (string-length s)) + (prefix (if (negative? n) "-" "")) + (pad-width (- width (string-length prefix) len))) + (if (<= pad-width 0) + (string-append prefix s) + (string-append prefix (make-string pad-width #\0) s)))))) + + (define (number->human-readable n) + (let loop ([v (exact->inexact (abs n))] + [suffixes '("" "K" "M" "G" "T" "P")]) + (cond + [(or (null? (cdr suffixes)) (< v 1024.0)) + (let ([rounded (/ (round (* v 10.0)) 10.0)]) + (string-append + (if (= rounded (floor rounded)) + (number->string (inexact->exact (floor rounded))) + (number->string rounded)) + (car suffixes)))] + [else + (loop (/ v 1024.0) (cdr suffixes))]))) + + (define (integer-length* n) + (if (zero? n) + 0 + (bitwise-length (abs n)))) + + ;; negative? and fixnum->flonum are re-exported from (chezscheme) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/walist.sls @@ -0,0 +1,55 @@ +#!chezscheme +;;; :std/misc/walist -- Weak association list (GC-friendly cache) +;;; +;;; Uses Chez Scheme's weak eq-hashtable so that keys can be +;;; reclaimed by the garbage collector. + +(library (std misc walist) + (export make-walist + walist-ref + walist-set! + walist-delete! + walist-keys + walist->alist + walist-length) + (import (chezscheme)) + + ;; A walist is just a wrapper around a weak eq-hashtable. + (define-record-type walist + (fields (immutable ht)) + (protocol + (lambda (new) + (lambda () + (new (make-weak-eq-hashtable)))))) + + (define (walist-ref w key) + (let ([ht (walist-ht w)]) + (hashtable-ref ht key #f))) + + (define (walist-set! w key val) + (let ([ht (walist-ht w)]) + (hashtable-set! ht key val))) + + (define (walist-delete! w key) + (let ([ht (walist-ht w)]) + (hashtable-delete! ht key))) + + (define (walist-keys w) + (let ([ht (walist-ht w)]) + (vector->list (hashtable-keys ht)))) + + (define (walist->alist w) + (let ([ht (walist-ht w)]) + (let-values ([(keys vals) (hashtable-entries ht)]) + (let lp ([i 0] [acc '()]) + (if (>= i (vector-length keys)) + (reverse acc) + (lp (+ i 1) + (cons (cons (vector-ref keys i) + (vector-ref vals i)) + acc))))))) + + (define (walist-length w) + (hashtable-size (walist-ht w))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/net/uri.sls @@ -0,0 +1,233 @@ +#!chezscheme +;;; :std/net/uri -- URI parsing and encoding + +(library (std net uri) + (export uri-parse + uri-scheme uri-host uri-port uri-path + uri-query uri-fragment uri-userinfo + uri-encode uri-decode + uri->string + query-string->alist + alist->query-string) + (import (chezscheme)) + + ;; URI record + (define-record-type uri + (fields scheme userinfo host port path query fragment) + (protocol + (lambda (new) + (lambda (scheme userinfo host port path query fragment) + (new scheme userinfo host port path query fragment))))) + + ;; Parse a URI string into a uri record. + ;; Format: scheme://userinfo@host:port/path?query#fragment + (define (uri-parse str) + (let* ([len (string-length str)] + [pos 0] + [scheme #f] [userinfo #f] [host #f] + [port #f] [path ""] [query #f] [fragment #f]) + ;; helper: find char starting at i, return index or #f + (define (find-char c i) + (let lp ([j i]) + (cond [(>= j len) #f] + [(char=? (string-ref str j) c) j] + [else (lp (+ j 1))]))) + ;; helper: substring + (define (sub start end) + (substring str start end)) + + ;; Parse fragment (from end) + (let ([hash-pos (find-char #\# pos)]) + (when hash-pos + (set! fragment (sub (+ hash-pos 1) len)) + (set! len hash-pos))) + + ;; Parse query + (let ([q-pos (find-char #\? pos)]) + (when q-pos + (set! query (sub (+ q-pos 1) len)) + (set! len q-pos))) + + ;; Parse scheme + (let ([colon-pos (find-char #\: pos)]) + (when (and colon-pos + (< (+ colon-pos 2) len) + (char=? (string-ref str (+ colon-pos 1)) #\/) + (char=? (string-ref str (+ colon-pos 2)) #\/)) + (set! scheme (sub pos colon-pos)) + (set! pos (+ colon-pos 3)))) + + ;; If we had a scheme, parse authority + (when scheme + ;; Find end of authority (next / or end) + (let ([slash-pos (find-char #\/ pos)]) + (let* ([auth-end (or slash-pos len)] + [auth (sub pos auth-end)]) + ;; Parse userinfo@ + (let ([at-pos (let lp ([j 0]) + (cond [(>= j (string-length auth)) #f] + [(char=? (string-ref auth j) #\@) j] + [else (lp (+ j 1))]))]) + (let ([host-start (if at-pos + (begin + (set! userinfo (substring auth 0 at-pos)) + (+ at-pos 1)) + 0)]) + ;; Parse host:port + (let ([colon (let lp ([j host-start]) + (cond [(>= j (string-length auth)) #f] + [(char=? (string-ref auth j) #\:) j] + [else (lp (+ j 1))]))]) + (if colon + (begin + (set! host (substring auth host-start colon)) + (set! port (string->number + (substring auth (+ colon 1) + (string-length auth))))) + (set! host (substring auth host-start + (string-length auth))))))) + ;; Remaining is path + (when slash-pos + (set! path (sub slash-pos len)))))) + + ;; No scheme -- treat entire remaining as path + (unless scheme + (set! path (sub pos len))) + + (make-uri scheme userinfo host port path query fragment))) + + ;; Percent-encoding + (define (unreserved-char? c) + (or (char-alphabetic? c) + (char-numeric? c) + (memv c '(#\- #\_ #\. #\~)))) + + (define (uri-encode str) + (let ([out (open-output-string)]) + (string-for-each + (lambda (c) + (if (unreserved-char? c) + (write-char c out) + (let ([b (char->integer c)]) + (if (< b 128) + (begin + (write-char #\% out) + (let ([hex (number->string b 16)]) + (when (< b 16) (write-char #\0 out)) + (display (string-upcase hex) out))) + ;; Multi-byte: encode UTF-8 bytes + (let ([bv (string->utf8 (string c))]) + (let lp ([i 0]) + (when (< i (bytevector-length bv)) + (write-char #\% out) + (let ([hex (number->string (bytevector-u8-ref bv i) 16)]) + (when (< (bytevector-u8-ref bv i) 16) + (write-char #\0 out)) + (display (string-upcase hex) out)) + (lp (+ i 1))))))))) + str) + (get-output-string out))) + + (define (hex-digit? c) + (or (char-numeric? c) + (memv (char-downcase c) '(#\a #\b #\c #\d #\e #\f)))) + + (define (hex-value c) + (let ([n (char->integer (char-downcase c))]) + (if (>= n (char->integer #\a)) + (+ 10 (- n (char->integer #\a))) + (- n (char->integer #\0))))) + + (define (uri-decode str) + (let ([out (open-output-string)] + [len (string-length str)]) + (let lp ([i 0]) + (when (< i len) + (let ([c (string-ref str i)]) + (cond + [(and (char=? c #\%) + (< (+ i 2) len) + (hex-digit? (string-ref str (+ i 1))) + (hex-digit? (string-ref str (+ i 2)))) + (write-char + (integer->char + (+ (* 16 (hex-value (string-ref str (+ i 1)))) + (hex-value (string-ref str (+ i 2))))) + out) + (lp (+ i 3))] + [(char=? c #\+) + (write-char #\space out) + (lp (+ i 1))] + [else + (write-char c out) + (lp (+ i 1))])))) + (get-output-string out))) + + ;; Reconstruct URI string from record + (define (uri->string u) + (let ([out (open-output-string)]) + (when (uri-scheme u) + (display (uri-scheme u) out) + (display "://" out)) + (when (uri-userinfo u) + (display (uri-userinfo u) out) + (display "@" out)) + (when (uri-host u) + (display (uri-host u) out)) + (when (uri-port u) + (display ":" out) + (display (uri-port u) out)) + (display (uri-path u) out) + (when (uri-query u) + (display "?" out) + (display (uri-query u) out)) + (when (uri-fragment u) + (display "#" out) + (display (uri-fragment u) out)) + (get-output-string out))) + + ;; Query string parsing + (define (query-string->alist qs) + (if (or (not qs) (string=? qs "")) + '() + (let lp ([pairs (string-split qs #\&)] + [acc '()]) + (if (null? pairs) + (reverse acc) + (let* ([pair (car pairs)] + [eq-pos (let scan ([j 0]) + (cond [(>= j (string-length pair)) #f] + [(char=? (string-ref pair j) #\=) j] + [else (scan (+ j 1))]))]) + (lp (cdr pairs) + (cons (if eq-pos + (cons (uri-decode (substring pair 0 eq-pos)) + (uri-decode (substring pair (+ eq-pos 1) + (string-length pair)))) + (cons (uri-decode pair) "")) + acc))))))) + + ;; Helper: split string by separator character + (define (string-split str sep) + (let ([len (string-length str)]) + (let lp ([i 0] [start 0] [acc '()]) + (cond + [(>= i len) + (reverse (cons (substring str start len) acc))] + [(char=? (string-ref str i) sep) + (lp (+ i 1) (+ i 1) + (cons (substring str start i) acc))] + [else (lp (+ i 1) start acc)])))) + + (define (alist->query-string alist) + (let ([out (open-output-string)]) + (let lp ([pairs alist] [first? #t]) + (unless (null? pairs) + (unless first? (display "&" out)) + (display (uri-encode (car (car pairs))) out) + (display "=" out) + (display (uri-encode (cdr (car pairs))) out) + (lp (cdr pairs) #f))) + (get-output-string out))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/values.sls @@ -0,0 +1,32 @@ +#!chezscheme +;;; :std/values -- Multiple values utilities + +(library (std values) + (export values->list + values-ref + receive) + (import (chezscheme)) + + ;; (values->list expr) -- captures multiple values as a list + (define-syntax values->list + (syntax-rules () + [(_ expr) + (call-with-values (lambda () expr) list)])) + + ;; (values-ref expr index) -- extract the nth value + (define-syntax values-ref + (syntax-rules () + [(_ expr index) + (call-with-values (lambda () expr) + (lambda args (list-ref args index)))])) + + ;; SRFI-8: receive + ;; (receive formals expr body ...) + ;; Binds the multiple values of expr to formals and evaluates body. + (define-syntax receive + (syntax-rules () + [(_ formals expr body ...) + (call-with-values (lambda () expr) + (lambda formals body ...))])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-newer-batch1.ss @@ -0,0 +1,244 @@ +#!chezscheme +;;; Tests for newer batch 1: list-builder, number, uri, walist, values, assert + +(import (chezscheme) + (std misc list-builder) + (std misc number) + (std net uri) + (std misc walist) + (std values) + (std assert)) + +(define pass-count 0) +(define fail-count 0) + +(define-syntax check + (syntax-rules (=>) + [(_ expr => expected) + (let ([result expr] + [exp expected]) + (if (equal? result exp) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (printf "FAIL: ~s => ~s (expected ~s)~n" 'expr result exp))))])) + +(define-syntax check-true + (syntax-rules () + [(_ expr) + (let ([result expr]) + (if result + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (printf "FAIL: ~s => ~s (expected truthy)~n" 'expr result))))])) + +(define-syntax check-false + (syntax-rules () + [(_ expr) + (let ([result expr]) + (if (not result) + (set! pass-count (+ pass-count 1)) + (begin + (set! fail-count (+ fail-count 1)) + (printf "FAIL: ~s => ~s (expected falsy)~n" 'expr result))))])) + +(printf "--- Testing newer batch 1 ---~n") + +;; ========== List Builder ========== +(printf " List builder...~n") +(check (with-list-builder (push!) + (push! 1) (push! 2) (push! 3)) + => '(1 2 3)) + +;; Preserves insertion order +(check (with-list-builder (push!) + (for-each (lambda (x) (when (> x 3) (push! x))) + '(1 5 2 7 3 8))) + => '(5 7 8)) + +;; Empty builder +(check (with-list-builder (push!)) => '()) + +;; Two-arg form with peek +(check (with-list-builder (push! peek) + (push! 'a) + (push! 'b) + (let ([so-far (peek)]) + (push! (length so-far)))) + => '(a b 2)) + +;; ========== Number utilities ========== +(printf " Number utilities...~n") +(check-true (natural? 0)) +(check-true (natural? 42)) +(check-false (natural? -1)) +(check-false (natural? 3.14)) + +(check-true (positive-integer? 1)) +(check-false (positive-integer? 0)) +(check-false (positive-integer? -1)) + +(check-true (negative? -1)) +(check-true (negative? -0.5)) +(check-false (negative? 0)) +(check-false (negative? 1)) + +(check (clamp 5 0 10) => 5) +(check (clamp -3 0 10) => 0) +(check (clamp 15 0 10) => 10) + +(let-values ([(q r) (divmod 7 3)]) + (check q => 2) + (check r => 1)) + +(check (number->padded-string 42 5) => "00042") +(check (number->padded-string 12345 3) => "12345") ;; wider than width +(check (number->padded-string 255 4 16) => "00ff") + +(let ([s (number->human-readable 1536)]) + (check-true (string? s)) + ;; Should contain "K" for kilobytes + (check-true (let loop ([i 0]) + (if (>= i (string-length s)) #f + (if (char=? (string-ref s i) #\K) #t + (loop (+ i 1))))))) + +(check (number->human-readable 42) => "42") + +(check (integer-length* 0) => 0) +(check (integer-length* 1) => 1) +(check (integer-length* 255) => 8) + +(check (fixnum->flonum 42) => 42.0) + +;; ========== URI parsing ========== +(printf " URI parsing...~n") +(let ([u (uri-parse "https://user:pass@example.com:8080/path/to?key=val&a=b#frag")]) + (check (uri-scheme u) => "https") + (check (uri-userinfo u) => "user:pass") + (check (uri-host u) => "example.com") + (check (uri-port u) => 8080) + (check (uri-path u) => "/path/to") + (check (uri-query u) => "key=val&a=b") + (check (uri-fragment u) => "frag")) + +;; Simple URL +(let ([u (uri-parse "http://example.com/test")]) + (check (uri-scheme u) => "http") + (check (uri-host u) => "example.com") + (check (uri-port u) => #f) + (check (uri-path u) => "/test") + (check (uri-query u) => #f) + (check (uri-fragment u) => #f)) + +;; URI reconstruction +(let ([u (uri-parse "https://example.com:443/api?q=1")]) + (let ([s (uri->string u)]) + (check-true (string? s)) + ;; Should round-trip the essential parts + (check-true (let loop ([i 0]) + (if (>= i (- (string-length s) 10)) #f + (if (string=? "example.com" (substring s i (+ i 11))) #t + (loop (+ i 1)))))))) + +;; Percent encoding +(check (uri-encode "hello world") => "hello%20world") +(check (uri-encode "a+b=c&d") => "a%2Bb%3Dc%26d") +(check (uri-decode "hello%20world") => "hello world") +(check (uri-decode "a%2Bb") => "a+b") + +;; Query string conversion +(let ([alist (query-string->alist "name=Alice&age=30&city=New+York")]) + (check-true (list? alist)) + (check-true (assoc "name" alist)) + (check (cdr (assoc "name" alist)) => "Alice") + (check (cdr (assoc "age" alist)) => "30")) + +(let ([qs (alist->query-string '(("x" . "1") ("y" . "hello world")))]) + (check-true (string? qs))) + +;; ========== Weak alist ========== +(printf " Weak alist...~n") +(let ([wa (make-walist)]) + (let ([key1 (list 'a)] + [key2 (list 'b)]) + (walist-set! wa key1 "value1") + (walist-set! wa key2 "value2") + (check (walist-ref wa key1) => "value1") + (check (walist-ref wa key2) => "value2") + (check (walist-length wa) => 2) + + ;; Delete + (walist-delete! wa key1) + (check (walist-ref wa key1) => #f) + (check (walist-length wa) => 1) + + ;; Keys and alist conversion + (let ([keys (walist-keys wa)]) + (check (length keys) => 1)) + (let ([alist (walist->alist wa)]) + (check (length alist) => 1) + (check (cdar alist) => "value2")))) + +;; ========== Values utilities ========== +(printf " Values utilities...~n") +(check (values->list (values 1 2 3)) => '(1 2 3)) +(check (values->list (values 'a)) => '(a)) +(check (values->list (values)) => '()) + +(check (values-ref (values 'a 'b 'c) 0) => 'a) +(check (values-ref (values 'a 'b 'c) 1) => 'b) +(check (values-ref (values 'a 'b 'c) 2) => 'c) + +;; receive (SRFI-8) +(check (receive (a b c) (values 1 2 3) (+ a b c)) => 6) +(check (receive (x) (values 42) x) => 42) +(check (receive args (values 1 2 3) args) => '(1 2 3)) + +;; ========== Assert ========== +(printf " Assert...~n") +;; assert! passes silently +(assert! #t) +(assert! (> 3 2)) +(assert! (> 3 2) "three is greater than two") +(set! pass-count (+ pass-count 3)) + +;; assert! fails with error +(check-true (guard (exn [#t #t]) + (assert! #f) + #f)) + +(check-true (guard (exn [#t #t]) + (assert! #f "custom message") + #f)) + +;; assert-equal! +(assert-equal! 42 42) +(assert-equal! "hello" "hello") +(set! pass-count (+ pass-count 2)) + +(check-true (guard (exn [#t #t]) + (assert-equal! 1 2) + #f)) + +;; assert-pred +(assert-pred number? 42) +(assert-pred string? "hello") +(set! pass-count (+ pass-count 2)) + +(check-true (guard (exn [#t #t]) + (assert-pred string? 42) + #f)) + +;; assert-exception +(let ([exn (assert-exception (lambda () (error 'test "boom")))]) + (check-true exn)) + +(check-true (guard (exn [#t #t]) + (assert-exception (lambda () 42)) + #f)) + +;; ========== Summary ========== +(printf "~n--- Results: ~a passed, ~a failed ---~n" pass-count fail-count) +(when (> fail-count 0) (exit 1))