Layer 3: Standard library with Gerbil-compatible APIs
ober
e9be56d6dd4c9e19a51623d21b33f32ba88b8dae
new file mode 100644 --- /dev/null +++ b/lib/std/error.sls @@ -0,0 +1,48 @@ +#!chezscheme +;;; :std/error -- Gerbil error types and utilities + +(library (std error) + (export + error? error-message error-irritants error-trace + Error ContractViolation + raise-error with-exception-handler) + (import (chezscheme)) + + ;; In Chez, errors are conditions. Provide Gerbil-compatible access. + + (define (error-message e) + (if (message-condition? e) + (condition-message e) + (format "~a" e))) + + (define (error-irritants e) + (if (irritants-condition? e) + (condition-irritants e) + '())) + + (define (error-trace e) + (if (condition? e) + (format "~a" e) + "")) + + ;; Error constructor compatible with Gerbil + (define (Error message . irritants) + (condition + (make-error) + (make-message-condition message) + (make-irritants-condition irritants))) + + (define (ContractViolation message . irritants) + (condition + (make-assertion-violation) + (make-message-condition message) + (make-irritants-condition irritants))) + + (define (raise-error where message . irritants) + (raise (condition + (make-error) + (make-who-condition where) + (make-message-condition message) + (make-irritants-condition irritants)))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/format.sls @@ -0,0 +1,21 @@ +#!chezscheme +;;; :std/format -- Gerbil-compatible format + +(library (std format) + (export format printf fprintf eprintf) + (import (except (chezscheme) printf fprintf)) + + ;; format is already in Chez, re-export it + ;; printf: format to stdout + (define (printf fmt . args) + (display (apply format fmt args))) + + ;; fprintf: format to port + (define (fprintf port fmt . args) + (display (apply format fmt args) port)) + + ;; eprintf: format to stderr + (define (eprintf fmt . args) + (display (apply format fmt args) (current-error-port))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/alist.sls @@ -0,0 +1,84 @@ +#!chezscheme +;;; :std/misc/alist -- Association list utilities + +(library (std misc alist) + (export agetq agetv aget + asetq! asetv! aset! + pgetq pgetv pget + alist->hash-table) + (import (except (chezscheme) make-hash-table hash-table? iota 1+ 1-) + (jerboa runtime)) + + (define agetq + (case-lambda + ((key alist) (agetq key alist #f)) + ((key alist default) + (cond [(assq key alist) => cdr] + [else default])))) + + (define agetv + (case-lambda + ((key alist) (agetv key alist #f)) + ((key alist default) + (cond [(assv key alist) => cdr] + [else default])))) + + (define aget + (case-lambda + ((key alist) (aget key alist #f)) + ((key alist default) + (cond [(assoc key alist) => cdr] + [else default])))) + + (define (asetq! key val alist) + (cond [(assq key alist) => (lambda (p) (set-cdr! p val) alist)] + [else (cons (cons key val) alist)])) + + (define (asetv! key val alist) + (cond [(assv key alist) => (lambda (p) (set-cdr! p val) alist)] + [else (cons (cons key val) alist)])) + + (define (aset! key val alist) + (cond [(assoc key alist) => (lambda (p) (set-cdr! p val) alist)] + [else (cons (cons key val) alist)])) + + ;; plist accessors (key val key val ...) + (define pgetq + (case-lambda + ((key plist) (pgetq key plist #f)) + ((key plist default) + (let loop ([rest plist]) + (cond + [(null? rest) default] + [(and (pair? (cdr rest)) (eq? (car rest) key)) (cadr rest)] + [(pair? (cdr rest)) (loop (cddr rest))] + [else default]))))) + + (define pgetv + (case-lambda + ((key plist) (pgetv key plist #f)) + ((key plist default) + (let loop ([rest plist]) + (cond + [(null? rest) default] + [(and (pair? (cdr rest)) (eqv? (car rest) key)) (cadr rest)] + [(pair? (cdr rest)) (loop (cddr rest))] + [else default]))))) + + (define pget + (case-lambda + ((key plist) (pget key plist #f)) + ((key plist default) + (let loop ([rest plist]) + (cond + [(null? rest) default] + [(and (pair? (cdr rest)) (equal? (car rest) key)) (cadr rest)] + [(pair? (cdr rest)) (loop (cddr rest))] + [else default]))))) + + (define (alist->hash-table alist) + (let ([ht (make-hash-table)]) + (for-each (lambda (p) (hash-put! ht (car p) (cdr p))) alist) + ht)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/channel.sls @@ -0,0 +1,54 @@ +#!chezscheme +;;; :std/misc/channel -- Gerbil-compatible channels using Chez threads + +(library (std misc channel) + (export make-channel channel-put channel-get channel-try-get + channel-close channel-closed? channel?) + (import (chezscheme)) + + (define-record-type channel + (fields + (mutable queue) + (immutable mutex) + (immutable condvar) + (mutable closed?)) + (protocol + (lambda (new) + (lambda () + (new '() (make-mutex) (make-condition) #f))))) + + (define (channel-put ch val) + (when (channel-closed? ch) + (error 'channel-put "channel is closed")) + (with-mutex (channel-mutex ch) + (channel-queue-set! ch (append (channel-queue ch) (list val))) + (condition-signal (channel-condvar ch)))) + + (define (channel-get ch) + (with-mutex (channel-mutex ch) + (let loop () + (cond + [(pair? (channel-queue ch)) + (let ([val (car (channel-queue ch))]) + (channel-queue-set! ch (cdr (channel-queue ch))) + val)] + [(channel-closed? ch) + (error 'channel-get "channel is closed and empty")] + [else + (condition-wait (channel-condvar ch) (channel-mutex ch)) + (loop)])))) + + (define (channel-try-get ch) + (with-mutex (channel-mutex ch) + (if (pair? (channel-queue ch)) + (let ([val (car (channel-queue ch))]) + (channel-queue-set! ch (cdr (channel-queue ch))) + (values val #t)) + (values #f #f)))) + + (define (channel-close ch) + (with-mutex (channel-mutex ch) + (channel-closed?-set! ch #t) + (condition-broadcast (channel-condvar ch)))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/list.sls @@ -0,0 +1,81 @@ +#!chezscheme +;;; :std/misc/list -- List utilities + +(library (std misc list) + (export flatten unique snoc + take drop + every any + filter-map + group-by + zip) + (import (chezscheme)) + + (define (flatten lst) + (cond + [(null? lst) '()] + [(pair? (car lst)) + (append (flatten (car lst)) (flatten (cdr lst)))] + [else (cons (car lst) (flatten (cdr lst)))])) + + (define unique + (case-lambda + ((lst) (unique lst equal?)) + ((lst same?) + (let loop ([rest lst] [acc '()]) + (if (null? rest) (reverse acc) + (if (exists (lambda (x) (same? x (car rest))) acc) + (loop (cdr rest) acc) + (loop (cdr rest) (cons (car rest) acc)))))))) + + (define (snoc lst item) + (append lst (list item))) + + (define take + (case-lambda + ((lst n) (take lst n '())) + ((lst n acc) + (if (or (zero? n) (null? lst)) + (reverse acc) + (take (cdr lst) (- n 1) (cons (car lst) acc)))))) + + (define (drop lst n) + (if (or (zero? n) (null? lst)) lst + (drop (cdr lst) (- n 1)))) + + (define (every pred lst) + (or (null? lst) + (and (pred (car lst)) + (every pred (cdr lst))))) + + (define (any pred lst) + (and (pair? lst) + (or (pred (car lst)) + (any pred (cdr lst))))) + + (define (filter-map proc lst) + (let loop ([rest lst] [acc '()]) + (if (null? rest) (reverse acc) + (let ([v (proc (car rest))]) + (loop (cdr rest) (if v (cons v acc) acc)))))) + + (define (group-by key lst) + (let ([ht (make-hashtable equal-hash equal?)]) + (for-each + (lambda (item) + (let ([k (key item)]) + (hashtable-update! ht k + (lambda (old) (cons item old)) + '()))) + lst) + (let-values ([(keys vals) (hashtable-entries ht)]) + (let loop ([i 0] [acc '()]) + (if (= i (vector-length keys)) acc + (loop (+ i 1) + (cons (cons (vector-ref keys i) + (reverse (vector-ref vals i))) + acc))))))) + + (define (zip . lists) + (apply map list lists)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/ports.sls @@ -0,0 +1,47 @@ +#!chezscheme +;;; :std/misc/ports -- Port utilities + +(library (std misc ports) + (export 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) + (import (except (chezscheme) with-input-from-string with-output-to-string)) + + (define (read-all-as-string port) + (let loop ([chars '()]) + (let ([ch (read-char port)]) + (if (eof-object? ch) + (list->string (reverse chars)) + (loop (cons ch chars)))))) + + (define (read-all-as-lines port) + (let loop ([lines '()]) + (let ([line (get-line port)]) + (if (eof-object? line) + (reverse lines) + (loop (cons line lines)))))) + + (define (read-file-string filename) + (call-with-input-file filename read-all-as-string)) + + (define (read-file-lines filename) + (call-with-input-file filename read-all-as-lines)) + + (define (write-file-string filename str) + (call-with-output-file filename + (lambda (port) (display str port)) + 'replace)) + + (define (with-input-from-string str thunk) + (let ([port (open-input-string str)]) + (parameterize ([current-input-port port]) + (thunk)))) + + (define (with-output-to-string thunk) + (let ([port (open-output-string)]) + (parameterize ([current-output-port port]) + (thunk)) + (get-output-string port))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/misc/string.sls @@ -0,0 +1,93 @@ +#!chezscheme +;;; :std/misc/string -- String utilities + +(library (std misc string) + (export string-split string-join string-trim + string-prefix? string-suffix? + string-contains string-index + string-empty?) + (import (chezscheme)) + + (define string-split + (case-lambda + ((str) (string-split str #\space)) + ((str sep) + (cond + [(char? sep) (string-split-char str sep)] + [(string? sep) (string-split-string str sep)] + [else (error 'string-split "separator must be char or string" sep)])))) + + (define (string-split-char str ch) + (let ([len (string-length str)]) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i len) + (reverse (cons (substring str start len) acc))] + [(char=? (string-ref str i) ch) + (loop (+ i 1) (+ i 1) (cons (substring str start i) acc))] + [else (loop (+ i 1) start acc)])))) + + (define (string-split-string str sep) + (let ([slen (string-length sep)] + [len (string-length str)]) + (if (zero? slen) + (map string (string->list str)) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(> (+ i slen) len) + (reverse (cons (substring str start len) acc))] + [(string=? (substring str i (+ i slen)) sep) + (loop (+ i slen) (+ i slen) + (cons (substring str start i) acc))] + [else (loop (+ i 1) start acc)]))))) + + (define string-join + (case-lambda + ((lst) (string-join lst " ")) + ((lst sep) + (if (null? lst) "" + (let loop ([rest (cdr lst)] [acc (car lst)]) + (if (null? rest) acc + (loop (cdr rest) (string-append acc sep (car rest))))))))) + + (define (string-trim str) + (let* ([len (string-length str)] + [start (let loop ([i 0]) + (if (and (< i len) (char-whitespace? (string-ref str i))) + (loop (+ i 1)) i))] + [end (let loop ([i (- len 1)]) + (if (and (>= i start) (char-whitespace? (string-ref str i))) + (loop (- i 1)) (+ i 1)))]) + (substring str start end))) + + (define (string-prefix? prefix str) + (and (<= (string-length prefix) (string-length str)) + (string=? prefix (substring str 0 (string-length prefix))))) + + (define (string-suffix? suffix str) + (let ([slen (string-length suffix)] + [len (string-length str)]) + (and (<= slen len) + (string=? suffix (substring str (- len slen) len))))) + + (define (string-contains str sub) + (let ([slen (string-length sub)] + [len (string-length str)]) + (let loop ([i 0]) + (cond + [(> (+ i slen) len) #f] + [(string=? (substring str i (+ i slen)) sub) i] + [else (loop (+ i 1))])))) + + (define (string-index str ch) + (let ([len (string-length str)]) + (let loop ([i 0]) + (cond + [(= i len) #f] + [(char=? (string-ref str i) ch) i] + [else (loop (+ i 1))])))) + + (define (string-empty? str) + (zero? (string-length str))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/os/path.sls @@ -0,0 +1,64 @@ +#!chezscheme +;;; :std/os/path -- Path utilities + +(library (std os path) + (export path-expand path-normalize path-directory path-strip-directory + path-extension path-strip-extension + path-join path-absolute?) + (import (except (chezscheme) path-extension path-absolute?)) + + (define (path-expand path) + (if (path-absolute? path) + path + (string-append (current-directory) "/" path))) + + (define (path-normalize path) + (path-expand path)) + + (define (path-directory path) + (let ([idx (string-last-index path #\/)]) + (if idx + (substring path 0 idx) + "."))) + + (define (path-strip-directory path) + (let ([idx (string-last-index path #\/)]) + (if idx + (substring path (+ idx 1) (string-length path)) + path))) + + (define (path-extension path) + (let ([base (path-strip-directory path)]) + (let ([idx (string-last-index base #\.)]) + (if idx + (substring base idx (string-length base)) + "")))) + + (define (path-strip-extension path) + (let ([idx (string-last-index path #\.)]) + (if idx + (substring path 0 idx) + path))) + + (define (path-join . parts) + (let loop ([rest parts] [acc ""]) + (if (null? rest) acc + (let ([part (car rest)]) + (loop (cdr rest) + (if (string=? acc "") + part + (string-append acc "/" part))))))) + + (define (path-absolute? path) + (and (> (string-length path) 0) + (char=? (string-ref path 0) #\/))) + + ;; Helper: find last index of char in string + (define (string-last-index str ch) + (let loop ([i (- (string-length str) 1)]) + (cond + [(< i 0) #f] + [(char=? (string-ref str i) ch) i] + [else (loop (- i 1))]))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/sort.sls @@ -0,0 +1,17 @@ +#!chezscheme +;;; :std/sort -- Gerbil-compatible sort API + +(library (std sort) + (export sort sort! stable-sort stable-sort!) + (import (except (chezscheme) sort sort!)) + + (define (sort lst less?) + (list-sort less? lst)) + + (define (sort! lst less?) + (list-sort less? lst)) + + (define stable-sort sort) + (define stable-sort! sort!) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/sugar.sls @@ -0,0 +1,84 @@ +#!chezscheme +;;; :std/sugar -- Gerbil sugar forms + +(library (std sugar) + (export + try catch finally + while until + hash-literal hash-eq-literal + let-hash + defrule defrules + chain chain-and with-id + assert!) + (import (except (chezscheme) + make-hash-table hash-table? iota 1+ 1-) + (jerboa core)) + + ;; chain: thread a value through a series of expressions + ;; (chain val (f _ arg) (g arg _)) → (g arg (f val arg)) + (define-syntax chain + (lambda (stx) + (syntax-case stx () + [(_ val) #'val] + [(_ val (f args ...) rest ...) + #'(chain (chain-apply f val args ...) rest ...)] + [(_ val f rest ...) + (identifier? #'f) + #'(chain (f val) rest ...)]))) + + (define-syntax chain-apply + (lambda (stx) + (syntax-case stx (_) + [(_ f val) #'(f val)] + [(_ f val _ arg ...) #'(f val arg ...)] + [(_ f val arg1 rest ...) + #'(chain-apply-tail f val (arg1) rest ...)]))) + + (define-syntax chain-apply-tail + (lambda (stx) + (syntax-case stx (_) + [(_ f val (args ...) _) #'(f args ... val)] + [(_ f val (args ...) _ rest ...) + #'(chain-apply-tail f val (args ... val) rest ...)] + [(_ f val (args ...) arg rest ...) + #'(chain-apply-tail f val (args ... arg) rest ...)] + [(_ f val (args ...)) #'(f args ...)]))) + + ;; chain-and: like chain but short-circuits on #f + (define-syntax chain-and + (syntax-rules () + [(_ val) val] + [(_ val step rest ...) + (let ([v val]) + (and v (chain-and (chain v step) rest ...)))])) + + ;; with-id: generate identifiers from a name + (define-syntax with-id + (lambda (stx) + (syntax-case stx () + [(_ name ((var fmt) ...) body ...) + (with-syntax ([(gen ...) (map (lambda (f) + (datum->syntax #'name + (string->symbol + (format (syntax->datum f) + (syntax->datum #'name))))) + (syntax->list #'(fmt ...)))]) + #'(let-syntax ([helper + (lambda (stx2) + (syntax-case stx2 () + [(_) + (with-syntax ([var (datum->syntax #'name 'gen)] ...) + #'(begin body ...))]))]) + (helper)))]))) + + ;; assert! + (define-syntax assert! + (syntax-rules () + [(_ expr) + (unless expr + (error 'assert! "assertion failed" 'expr))] + [(_ expr message) + (unless expr + (error 'assert! message 'expr))])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/text/json.sls @@ -0,0 +1,201 @@ +#!chezscheme +;;; :std/text/json -- JSON reader/writer +;;; +;;; JSON ↔ Scheme mapping: +;;; object → hashtable +;;; array → list +;;; string → string +;;; number → number +;;; true → #t +;;; false → #f +;;; null → (void) + +(library (std text json) + (export read-json write-json + string->json-object json-object->string) + (import (except (chezscheme) make-hash-table hash-table? iota 1+ 1-) + (jerboa runtime)) + + ;;;; ---- Reader ---- + + (define (read-json . args) + (let ([port (if (null? args) (current-input-port) (car args))]) + (json-read-value port))) + + (define (string->json-object str) + (let ([port (open-input-string str)]) + (json-read-value port))) + + (define (json-skip-whitespace port) + (let loop () + (let ([ch (peek-char port)]) + (when (and (char? ch) (char-whitespace? ch)) + (read-char port) + (loop))))) + + (define (json-read-value port) + (json-skip-whitespace port) + (let ([ch (peek-char port)]) + (cond + [(eof-object? ch) (error 'read-json "unexpected EOF")] + [(char=? ch #\") (json-read-string port)] + [(char=? ch #\{) (json-read-object port)] + [(char=? ch #\[) (json-read-array port)] + [(char=? ch #\t) (json-read-literal port "true" #t)] + [(char=? ch #\f) (json-read-literal port "false" #f)] + [(char=? ch #\n) (json-read-literal port "null" (void))] + [(or (char=? ch #\-) (char-numeric? ch)) (json-read-number port)] + [else (error 'read-json "unexpected character" ch)]))) + + (define (json-read-string port) + (read-char port) ;; consume opening " + (let loop ([chars '()]) + (let ([ch (read-char port)]) + (cond + [(eof-object? ch) (error 'read-json "unterminated string")] + [(char=? ch #\") (list->string (reverse chars))] + [(char=? ch #\\) + (let ([esc (read-char port)]) + (cond + [(char=? esc #\") (loop (cons #\" chars))] + [(char=? esc #\\) (loop (cons #\\ chars))] + [(char=? esc #\/) (loop (cons #\/ chars))] + [(char=? esc #\n) (loop (cons #\newline chars))] + [(char=? esc #\t) (loop (cons #\tab chars))] + [(char=? esc #\r) (loop (cons #\return chars))] + [(char=? esc #\b) (loop (cons #\backspace chars))] + [(char=? esc #\f) (loop (cons #\xC chars))] ;; formfeed + [(char=? esc #\u) + (let* ([hex (string (read-char port) (read-char port) + (read-char port) (read-char port))] + [cp (string->number hex 16)]) + (loop (cons (integer->char cp) chars)))] + [else (loop (cons esc chars))]))] + [else (loop (cons ch chars))])))) + + (define (json-read-object port) + (read-char port) ;; consume { + (json-skip-whitespace port) + (let ([ht (make-hash-table)]) + (if (char=? (peek-char port) #\}) + (begin (read-char port) ht) + (let loop () + (json-skip-whitespace port) + (let ([key (json-read-string port)]) + (json-skip-whitespace port) + (let ([colon (read-char port)]) + (unless (char=? colon #\:) + (error 'read-json "expected ':'" colon))) + (let ([val (json-read-value port)]) + (hash-put! ht key val) + (json-skip-whitespace port) + (let ([ch (read-char port)]) + (cond + [(char=? ch #\}) ht] + [(char=? ch #\,) (loop)] + [else (error 'read-json "expected ',' or '}'" ch)])))))))) + + (define (json-read-array port) + (read-char port) ;; consume [ + (json-skip-whitespace port) + (if (char=? (peek-char port) #\]) + (begin (read-char port) '()) + (let loop ([acc '()]) + (let ([val (json-read-value port)]) + (json-skip-whitespace port) + (let ([ch (read-char port)]) + (cond + [(char=? ch #\]) (reverse (cons val acc))] + [(char=? ch #\,) (loop (cons val acc))] + [else (error 'read-json "expected ',' or ']'" ch)])))))) + + (define (json-read-literal port expected value) + (let ([n (string-length expected)]) + (let loop ([i 0]) + (if (= i n) value + (let ([ch (read-char port)]) + (if (char=? ch (string-ref expected i)) + (loop (+ i 1)) + (error 'read-json "unexpected literal" ch))))))) + + (define (json-read-number port) + (let loop ([chars '()]) + (let ([ch (peek-char port)]) + (if (and (char? ch) + (or (char-numeric? ch) + (memv ch '(#\. #\- #\+ #\e #\E)))) + (begin (read-char port) (loop (cons ch chars))) + (let ([s (list->string (reverse chars))]) + (or (string->number s) + (error 'read-json "invalid number" s))))))) + + ;;;; ---- Writer ---- + + (define (write-json val . args) + (let ([port (if (null? args) (current-output-port) (car args))]) + (json-write-value val port))) + + (define (json-object->string val) + (let ([port (open-output-string)]) + (json-write-value val port) + (get-output-string port))) + + (define (json-write-value val port) + (cond + [(string? val) (json-write-string val port)] + [(number? val) (json-write-number val port)] + [(eq? val #t) (display "true" port)] + [(eq? val #f) (display "false" port)] + [(eq? val (void)) (display "null" port)] + [(hashtable? val) (json-write-object val port)] + [(list? val) (json-write-array val port)] + [(symbol? val) (json-write-string (symbol->string val) port)] + [else (error 'write-json "cannot serialize" val)])) + + (define (json-write-string str port) + (display #\" port) + (string-for-each + (lambda (ch) + (cond + [(char=? ch #\") (display "\\\"" port)] + [(char=? ch #\\) (display "\\\\" port)] + [(char=? ch #\newline) (display "\\n" port)] + [(char=? ch #\tab) (display "\\t" port)] + [(char=? ch #\return) (display "\\r" port)] + [(char<? ch #\space) + (display (format "\\u~4,'0x" (char->integer ch)) port)] + [else (display ch port)])) + str) + (display #\" port)) + + (define (json-write-number n port) + (if (and (integer? n) (exact? n)) + (display n port) + (display (format "~a" (inexact n)) port))) + + (define (json-write-object ht port) + (display "{" port) + (let-values ([(keys vals) (hashtable-entries ht)]) + (let ([len (vector-length keys)]) + (let loop ([i 0]) + (when (< i len) + (when (> i 0) (display "," port)) + (json-write-string + (let ([k (vector-ref keys i)]) + (if (string? k) k (format "~a" k))) + port) + (display ":" port) + (json-write-value (vector-ref vals i) port) + (loop (+ i 1)))))) + (display "}" port)) + + (define (json-write-array lst port) + (display "[" port) + (let loop ([rest lst] [first #t]) + (when (pair? rest) + (unless first (display "," port)) + (json-write-value (car rest) port) + (loop (cdr rest) #f))) + (display "]" port)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/tests/test-stdlib.ss @@ -0,0 +1,167 @@ +#!chezscheme +;;; test-stdlib.ss -- Tests for Jerboa standard library modules + +(import (except (chezscheme) make-hash-table hash-table? iota 1+ 1- + sort sort! + printf fprintf + path-extension path-absolute? + with-input-from-string with-output-to-string) + (jerboa runtime) + (std sort) + (std format) + (std error) + (std text json) + (std os path) + (std misc string) + (std misc list) + (std misc alist) + (std misc ports)) + +(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)) + (display "FAIL: ") + (write 'expr) + (display " => ") + (write result) + (display " expected ") + (write exp) + (newline))))])) + +;;; ---- std/sort ---- + +(check (sort '(3 1 2) <) => '(1 2 3)) +(check (sort '("b" "a" "c") string<?) => '("a" "b" "c")) +(check (sort '() <) => '()) + +;;; ---- std/format ---- + +(check (format "~a + ~a = ~a" 1 2 3) => "1 + 2 = 3") +(let ([out (open-output-string)]) + (fprintf out "hello ~a" "world") + (check (get-output-string out) => "hello world")) + +;;; ---- std/error ---- + +(let ([err (Error "test error" 'detail)]) + (check (error-message err) => "test error") + (check (error-irritants err) => '(detail))) + +;;; ---- std/text/json ---- + +;; Read +(check (string->json-object "42") => 42) +(check (string->json-object "\"hello\"") => "hello") +(check (string->json-object "true") => #t) +(check (string->json-object "false") => #f) +(check (string->json-object "[1,2,3]") => '(1 2 3)) +(check (string->json-object "[]") => '()) + +;; Read object +(let ([obj (string->json-object "{\"name\":\"Alice\",\"age\":30}")]) + (check (hash-ref obj "name") => "Alice") + (check (hash-ref obj "age") => 30)) + +;; Read nested +(let ([obj (string->json-object "{\"items\":[1,2,3]}")]) + (check (hash-ref obj "items") => '(1 2 3))) + +;; Write +(check (json-object->string 42) => "42") +(check (json-object->string "hello") => "\"hello\"") +(check (json-object->string #t) => "true") +(check (json-object->string #f) => "false") +(check (json-object->string '(1 2 3)) => "[1,2,3]") + +;; Write string escapes +(check (json-object->string "a\"b") => "\"a\\\"b\"") +(check (json-object->string "a\nb") => "\"a\\nb\"") + +;; Roundtrip +(let ([data '(1 "two" #t #f)]) + (check (string->json-object (json-object->string data)) => data)) + +;;; ---- std/os/path ---- + +(check (path-directory "/home/user/file.txt") => "/home/user") +(check (path-strip-directory "/home/user/file.txt") => "file.txt") +(check (path-extension "/home/user/file.txt") => ".txt") +(check (path-strip-extension "/home/user/file.txt") => "/home/user/file") +(check (path-join "home" "user" "file.txt") => "home/user/file.txt") +(check (path-absolute? "/home") => #t) +(check (path-absolute? "home") => #f) + +;;; ---- std/misc/string ---- + +(check (string-split "a,b,c" #\,) => '("a" "b" "c")) +(check (string-split "a::b::c" "::") => '("a" "b" "c")) +(check (string-split "hello") => '("hello")) +(check (string-join '("a" "b" "c") ",") => "a,b,c") +(check (string-join '("hello") " ") => "hello") +(check (string-trim " hello ") => "hello") +(check (string-prefix? "he" "hello") => #t) +(check (string-prefix? "xx" "hello") => #f) +(check (string-suffix? "lo" "hello") => #t) +(check (string-contains "hello world" "world") => 6) +(check (string-contains "hello" "xyz") => #f) +(check (string-index "hello" #\l) => 2) +(check (string-empty? "") => #t) +(check (string-empty? "x") => #f) + +;;; ---- std/misc/list ---- + +(check (flatten '(1 (2 3) ((4) 5))) => '(1 2 3 4 5)) +(check (unique '(1 2 1 3 2)) => '(1 2 3)) +(check (snoc '(1 2) 3) => '(1 2 3)) +(check (take '(1 2 3 4 5) 3) => '(1 2 3)) +(check (drop '(1 2 3 4 5) 2) => '(3 4 5)) +(check (every positive? '(1 2 3)) => #t) +(check (every positive? '(1 -2 3)) => #f) +(check (any negative? '(1 -2 3)) => #t) +(check (any negative? '(1 2 3)) => #f) +(check (filter-map (lambda (x) (and (> x 2) (* x 10))) '(1 2 3 4)) + => '(30 40)) +(check (zip '(1 2 3) '(a b c)) => '((1 a) (2 b) (3 c))) + +;;; ---- std/misc/alist ---- + +(let ([al '((a . 1) (b . 2) (c . 3))]) + (check (agetq 'a al) => 1) + (check (agetq 'z al) => #f) + (check (agetq 'z al 99) => 99)) + +(let ([pl '(a 1 b 2 c 3)]) + (check (pgetq 'a pl) => 1) + (check (pgetq 'c pl) => 3) + (check (pgetq 'z pl) => #f)) + +;;; ---- std/misc/ports ---- + +(check (with-output-to-string (lambda () (display "hello"))) + => "hello") + +(check (with-input-from-string "hello" + (lambda () (read-all-as-string (current-input-port)))) + => "hello") + +(check (read-all-as-lines (open-input-string "a\nb\nc")) + => '("a" "b" "c")) + +;;; ---- Summary ---- +(newline) +(display "Stdlib tests: ") +(display pass-count) +(display " passed, ") +(display fail-count) +(display " failed") +(newline) +(when (> fail-count 0) (exit 1))