Add hierarchical S-expression configuration library (#42)
ober
f7fa1efd9f33f8d9cd6cb43b271e8734d007e321
new file mode 100644 --- /dev/null +++ b/lib/std/misc/config.sls @@ -0,0 +1,178 @@ +#!chezscheme +;;; (std misc config) — Hierarchical s-expression configuration +;;; +;;; (define cfg (make-config '((host . "localhost") (port . 8080)))) +;;; (define child (make-config '((port . 9090)) cfg)) +;;; (config-ref child 'host) => "localhost" (cascades to parent) +;;; (config-ref child 'port) => 9090 (child overrides) + +(library (std misc config) + (export make-config config? config-ref config-ref/default + config-set config-keys config-merge config-from-file + config-subsection config-verify config->alist + with-config current-config) + (import (chezscheme)) + + ;; Internal record: alist of key-value pairs + optional parent config + (define-record-type config-record + (fields + (immutable alist) + (immutable parent))) + + (define (config? x) + (config-record? x)) + + ;; Create a config from an alist with optional parent + (define make-config + (case-lambda + [(alist) + (make-config alist #f)] + [(alist parent) + (unless (list? alist) + (error 'make-config "alist must be a list" alist)) + (when (and parent (not (config? parent))) + (error 'make-config "parent must be a config or #f" parent)) + (make-config-record alist parent)])) + + ;; Lookup a key, cascading to parent if not found locally + (define (config-ref cfg key) + (unless (config? cfg) + (error 'config-ref "not a config" cfg)) + (let ([pair (assq key (config-record-alist cfg))]) + (if pair + (cdr pair) + (let ([parent (config-record-parent cfg)]) + (if parent + (config-ref parent key) + (error 'config-ref "key not found" key)))))) + + ;; Lookup with default value — never errors on missing key + (define (config-ref/default cfg key default) + (unless (config? cfg) + (error 'config-ref/default "not a config" cfg)) + (let ([pair (assq key (config-record-alist cfg))]) + (if pair + (cdr pair) + (let ([parent (config-record-parent cfg)]) + (if parent + (config-ref/default parent key default) + default))))) + + ;; Functional update: return new config with key set + (define (config-set cfg key value) + (unless (config? cfg) + (error 'config-set "not a config" cfg)) + (let ([new-alist + (cons (cons key value) + (remp (lambda (p) (eq? (car p) key)) + (config-record-alist cfg)))]) + (make-config-record new-alist (config-record-parent cfg)))) + + ;; List all keys including parent keys (no duplicates) + (define (config-keys cfg) + (unless (config? cfg) + (error 'config-keys "not a config" cfg)) + (let loop ([c cfg] [seen '()]) + (if (not c) + (reverse seen) + (let ([new-keys + (filter (lambda (k) (not (memq k seen))) + (map car (config-record-alist c)))]) + (loop (config-record-parent c) + (append seen new-keys)))))) + + ;; Merge two configs: second overrides first. Neither's parent is preserved; + ;; the result is a flat config with first as parent of second's entries. + (define (config-merge base override) + (unless (config? base) + (error 'config-merge "not a config" base)) + (unless (config? override) + (error 'config-merge "not a config" override)) + (let ([base-flat (config->alist base)] + [override-flat (config->alist override)]) + (let ([merged + (fold-left + (lambda (acc pair) + (cons pair (remp (lambda (p) (eq? (car p) (car pair))) acc))) + base-flat + override-flat)]) + (make-config-record merged #f)))) + + ;; Read config from an s-expression file + ;; File should contain an alist, e.g.: ((host . "localhost") (port . 8080)) + (define config-from-file + (case-lambda + [(path) + (config-from-file path #f)] + [(path parent) + (let ([data (call-with-input-file path read)]) + (unless (list? data) + (error 'config-from-file "file must contain an alist" path)) + (make-config data parent))])) + + ;; Extract a nested section as a new config + ;; If key maps to an alist, wrap it as a config + (define config-subsection + (case-lambda + [(cfg key) + (config-subsection cfg key #f)] + [(cfg key parent) + (let ([val (config-ref cfg key)]) + (unless (list? val) + (error 'config-subsection + "value for key is not an alist" key val)) + (make-config val parent))])) + + ;; Validate config against a schema + ;; Schema is an alist of (key . predicate) pairs + ;; Returns list of error strings, or '() if valid + (define (config-verify schema cfg) + (unless (config? cfg) + (error 'config-verify "not a config" cfg)) + (let loop ([schema schema] [errors '()]) + (if (null? schema) + (reverse errors) + (let* ([entry (car schema)] + [key (car entry)] + [pred (cdr entry)] + [pair (let find ([c cfg]) + (if (not c) + #f + (let ([p (assq key (config-record-alist c))]) + (if p p (find (config-record-parent c))))))]) + (cond + [(not pair) + (loop (cdr schema) + (cons (format "missing key: ~a" key) errors))] + [(not (pred (cdr pair))) + (loop (cdr schema) + (cons (format "invalid value for ~a: ~s" key (cdr pair)) + errors))] + [else + (loop (cdr schema) errors)]))))) + + ;; Convert config (with parent resolution) to a flat alist + ;; Child values override parent values + (define (config->alist cfg) + (unless (config? cfg) + (error 'config->alist "not a config" cfg)) + (let loop ([c cfg] [acc '()]) + (if (not c) + acc + (let ([new-pairs + (filter (lambda (p) (not (assq (car p) acc))) + (config-record-alist c))]) + (loop (config-record-parent c) + (append acc new-pairs)))))) + + ;; Parameter for dynamic scoping + (define current-config (make-parameter #f)) + + ;; Parameterize with a config for dynamic scoping + (define-syntax with-config + (syntax-rules () + [(_ cfg body ...) + (parameterize ([current-config cfg]) + body ...)])) + +) ;; end library --- a/tests/test-config.ss +++ b/tests/test-config.ss @@ -1,115 +1,267 @@ +#!/usr/bin/env scheme-script #!chezscheme -;;; tests/test-config.ss -- Tests for (std config) - -(import (chezscheme) (std config)) - -(define pass 0) -(define fail 0) - -(define-syntax test - (syntax-rules () - [(_ name expr expected) - (guard (exn [#t (set! fail (+ fail 1)) - (printf "FAIL ~a: ~a~%" name - (if (message-condition? exn) (condition-message exn) exn))]) - (let ([got expr]) - (if (equal? got expected) - (begin (set! pass (+ pass 1)) (printf " ok ~a~%" name)) - (begin (set! fail (+ fail 1)) - (printf "FAIL ~a: got ~s expected ~s~%" name got expected)))))])) - -(printf "--- Phase 2e: Config ---~%~%") - -;; ---- 1. make-config / config? ---- -(let ([cfg (make-config)]) - (test "config?" (config? cfg) #t) - (test "empty-get" (config-get cfg 'foo) #f) - (test "empty-get-default" (config-get cfg 'foo "bar") "bar")) - -;; ---- 2. config-set! / config-get ---- -(let ([cfg (make-config)]) - (config-set! cfg 'name "Alice") - (config-set! cfg 'age 30) - (test "config-set-string" (config-get cfg 'name) "Alice") - (test "config-set-int" (config-get cfg 'age) 30)) - -;; ---- 3. config-ref ---- -(let ([cfg (make-config)]) - (config-set! cfg 'key "value") - (test "config-ref" (config-ref cfg 'key) "value") - (test "config-ref-missing" (config-ref cfg 'missing) #f)) - -;; ---- 4. config-ref* ---- -(let ([cfg (make-config)]) - (config-set! cfg 'a 1) - (config-set! cfg 'b 2) - (test "config-ref*" (config-ref* cfg 'a 'b) '(1 2))) - -;; ---- 5. config-merge! with alist ---- -(let ([cfg (make-config)]) - (config-merge! cfg '((x . 10) (y . 20) (z . "hello"))) - (test "merge-x" (config-get cfg 'x) 10) - (test "merge-y" (config-get cfg 'y) 20) - (test "merge-z" (config-get cfg 'z) "hello")) - -;; ---- 6. config-schema / validate-config ---- -(let ([cfg (make-config)] - [schema '((name string "default") (port integer 8080) (debug boolean #f))]) - (config-set! cfg 'name "myapp") - (config-set! cfg 'port 3000) - (config-set! cfg 'debug #t) - (let ([errors (validate-config cfg)]) - (test "validate-ok" errors '())) - (test "config-valid?" (config-valid? cfg) #t)) - -;; ---- 7. validate-config catches type errors ---- -;; Load config with schema - schema is attached at load time -(let* ([tmpfile "/tmp/test-config-schema.sexp"] - [_ (call-with-output-file tmpfile - (lambda (p) (write '((count . "not-a-number")) p)) - 'truncate)] - [schema '((count integer 0))] - [cfg (load-config tmpfile schema)]) - (let ([errors (validate-config cfg)]) - (test "validate-error-count" (length errors) 1) - (test "validate-error-key" (caar errors) 'count)) - (delete-file tmpfile)) - -;; ---- 8. watch-config! triggers on set ---- -(let ([cfg (make-config)] - [watch-log '()]) - (watch-config! cfg (lambda (k v) (set! watch-log (cons (cons k v) watch-log)))) - (config-set! cfg 'foo 42) - (config-set! cfg 'bar "baz") - (test "watch-count" (length watch-log) 2) - (test "watch-first" (cdar watch-log) "baz")) - -;; ---- 9. save-config and load-config ---- -(let ([tmpfile "/tmp/test-config.sexp"] - [cfg (make-config)]) - (config-set! cfg 'host "localhost") - (config-set! cfg 'port 9090) - (save-config cfg tmpfile) - (test "save-creates-file" (file-exists? tmpfile) #t) - ;; Load it back - (let ([cfg2 (load-config tmpfile)]) - (test "load-config-host" (config-get cfg2 'host) "localhost") - (test "load-config-port" (config-get cfg2 'port) 9090)) - (delete-file tmpfile)) - -;; ---- 10. load-config from non-existent file returns empty config ---- -(let ([cfg (load-config "/tmp/nonexistent-config-999.sexp")]) - (test "load-nonexistent" (config? cfg) #t) - (test "load-nonexistent-empty" (config-get cfg 'x) #f)) - -;; ---- 11. with-config macro ---- -(let ([cfg (make-config)]) - (config-set! cfg 'width 800) - (config-set! cfg 'height 600) - ;; with-config binds vars from config by key - (with-config cfg ([w width] [h height]) - (test "with-config-w" w 800) - (test "with-config-h" h 600))) - -(printf "~%Results: ~a passed, ~a failed~%" pass fail) -(when (> fail 0) (exit 1)) +(import (chezscheme) + (std misc config)) + +(define test-count 0) +(define pass-count 0) + +(define (test name thunk) + (set! test-count (+ test-count 1)) + (guard (e [#t (display "FAIL: ") (display name) (newline) + (display " Error: ") (display (condition-message e)) (newline)]) + (thunk) + (set! pass-count (+ pass-count 1)) + (display "PASS: ") (display name) (newline))) + +(define (assert-equal actual expected msg) + (unless (equal? actual expected) + (error 'assert-equal + (string-append msg ": expected " (format "~s" expected) + " got " (format "~s" actual))))) + +(define (assert-true val msg) + (unless val + (error 'assert-true (string-append msg ": expected #t")))) + +;; Test 1: basic make-config and config-ref +(test "make-config and config-ref" + (lambda () + (let ([cfg (make-config '((host . "localhost") (port . 8080)))]) + (assert-true (config? cfg) "is a config") + (assert-equal (config-ref cfg 'host) "localhost" "host") + (assert-equal (config-ref cfg 'port) 8080 "port")))) + +;; Test 2: config-ref missing key raises error +(test "config-ref missing key errors" + (lambda () + (let ([cfg (make-config '((x . 1)))]) + (let ([got-error #f]) + (guard (e [#t (set! got-error #t)]) + (config-ref cfg 'missing)) + (assert-true got-error "should error on missing key"))))) + +;; Test 3: parent cascading +(test "parent cascading" + (lambda () + (let* ([parent (make-config '((host . "prod.example.com") (port . 443) (debug . #f)))] + [child (make-config '((port . 9090) (name . "dev")) parent)]) + (assert-equal (config-ref child 'port) 9090 "child overrides port") + (assert-equal (config-ref child 'host) "prod.example.com" "cascades to parent for host") + (assert-equal (config-ref child 'debug) #f "cascades to parent for debug") + (assert-equal (config-ref child 'name) "dev" "child-only key")))) + +;; Test 4: config-ref/default +(test "config-ref/default" + (lambda () + (let ([cfg (make-config '((x . 42)))]) + (assert-equal (config-ref/default cfg 'x 0) 42 "existing key") + (assert-equal (config-ref/default cfg 'missing 99) 99 "missing key returns default")))) + +;; Test 5: config-ref/default with parent +(test "config-ref/default cascades to parent" + (lambda () + (let* ([parent (make-config '((a . 1)))] + [child (make-config '((b . 2)) parent)]) + (assert-equal (config-ref/default child 'a 0) 1 "found in parent") + (assert-equal (config-ref/default child 'b 0) 2 "found in child") + (assert-equal (config-ref/default child 'c 99) 99 "not found anywhere")))) + +;; Test 6: config-set functional update +(test "config-set returns new config" + (lambda () + (let* ([cfg (make-config '((x . 1) (y . 2)))] + [cfg2 (config-set cfg 'x 10)]) + (assert-equal (config-ref cfg 'x) 1 "original unchanged") + (assert-equal (config-ref cfg2 'x) 10 "new config updated") + (assert-equal (config-ref cfg2 'y) 2 "other key preserved")))) + +;; Test 7: config-set adds new key +(test "config-set adds new key" + (lambda () + (let* ([cfg (make-config '((x . 1)))] + [cfg2 (config-set cfg 'y 2)]) + (assert-equal (config-ref cfg2 'x) 1 "old key") + (assert-equal (config-ref cfg2 'y) 2 "new key")))) + +;; Test 8: config-keys +(test "config-keys includes parent keys" + (lambda () + (let* ([parent (make-config '((a . 1) (b . 2)))] + [child (make-config '((b . 20) (c . 3)) parent)]) + (let ([keys (config-keys child)]) + (assert-true (memq 'a keys) "parent key a") + (assert-true (memq 'b keys) "shared key b") + (assert-true (memq 'c keys) "child key c") + (assert-equal (length keys) 3 "no duplicates"))))) + +;; Test 9: config-merge +(test "config-merge second overrides first" + (lambda () + (let* ([base (make-config '((host . "old") (port . 80) (debug . #t)))] + [override (make-config '((port . 443) (tls . #t)))] + [merged (config-merge base override)]) + (assert-equal (config-ref merged 'host) "old" "kept from base") + (assert-equal (config-ref merged 'port) 443 "overridden") + (assert-equal (config-ref merged 'debug) #t "kept from base") + (assert-equal (config-ref merged 'tls) #t "added from override")))) + +;; Test 10: config-from-file +(test "config-from-file reads s-expression" + (lambda () + (let ([path "/tmp/test-config-jerboa.scm"]) + (call-with-output-file path + (lambda (p) + (write '((host . "filehost") (port . 3000)) p)) + 'replace) + (let ([cfg (config-from-file path)]) + (assert-equal (config-ref cfg 'host) "filehost" "host from file") + (assert-equal (config-ref cfg 'port) 3000 "port from file")) + (delete-file path)))) + +;; Test 11: config-from-file with parent +(test "config-from-file with parent" + (lambda () + (let ([path "/tmp/test-config-jerboa2.scm"]) + (call-with-output-file path + (lambda (p) + (write '((port . 9999)) p)) + 'replace) + (let* ([parent (make-config '((host . "parent-host")))] + [cfg (config-from-file path parent)]) + (assert-equal (config-ref cfg 'port) 9999 "from file") + (assert-equal (config-ref cfg 'host) "parent-host" "from parent")) + (delete-file path)))) + +;; Test 12: config-subsection +(test "config-subsection extracts nested alist" + (lambda () + (let ([cfg (make-config + `((database . ((host . "db.local") (port . 5432))) + (app-name . "myapp")))]) + (let ([db-cfg (config-subsection cfg 'database)]) + (assert-true (config? db-cfg) "subsection is a config") + (assert-equal (config-ref db-cfg 'host) "db.local" "nested host") + (assert-equal (config-ref db-cfg 'port) 5432 "nested port"))))) + +;; Test 13: config-subsection with parent +(test "config-subsection with parent" + (lambda () + (let* ([defaults (make-config '((timeout . 30)))] + [cfg (make-config + `((database . ((host . "db.local")))))] + [db-cfg (config-subsection cfg 'database defaults)]) + (assert-equal (config-ref db-cfg 'host) "db.local" "from subsection") + (assert-equal (config-ref db-cfg 'timeout) 30 "from parent")))) + +;; Test 14: config-verify valid config +(test "config-verify valid config returns empty" + (lambda () + (let ([cfg (make-config '((port . 8080) (host . "localhost")))] + [schema (list (cons 'port number?) (cons 'host string?))]) + (assert-equal (config-verify schema cfg) '() "no errors")))) + +;; Test 15: config-verify missing key +(test "config-verify detects missing key" + (lambda () + (let ([cfg (make-config '((port . 8080)))] + [schema (list (cons 'port number?) (cons 'host string?))]) + (let ([errors (config-verify schema cfg)]) + (assert-equal (length errors) 1 "one error") + (assert-true (string? (car errors)) "error is a string"))))) + +;; Test 16: config-verify wrong type +(test "config-verify detects wrong type" + (lambda () + (let ([cfg (make-config '((port . "not-a-number") (host . "ok")))] + [schema (list (cons 'port number?) (cons 'host string?))]) + (let ([errors (config-verify schema cfg)]) + (assert-equal (length errors) 1 "one error"))))) + +;; Test 17: config-verify checks parent values +(test "config-verify finds values in parent" + (lambda () + (let* ([parent (make-config '((host . "parenthost")))] + [child (make-config '((port . 80)) parent)] + [schema (list (cons 'port number?) (cons 'host string?))]) + (assert-equal (config-verify schema child) '() "no errors")))) + +;; Test 18: config->alist +(test "config->alist flattens with parent" + (lambda () + (let* ([parent (make-config '((a . 1) (b . 2)))] + [child (make-config '((b . 20) (c . 3)) parent)] + [flat (config->alist child)]) + (assert-equal (cdr (assq 'a flat)) 1 "parent key") + (assert-equal (cdr (assq 'b flat)) 20 "child overrides parent") + (assert-equal (cdr (assq 'c flat)) 3 "child key") + (assert-equal (length flat) 3 "no duplicates")))) + +;; Test 19: with-config and current-config +(test "with-config sets current-config" + (lambda () + (let ([cfg (make-config '((x . 42)))]) + (assert-equal (current-config) #f "initially #f") + (with-config cfg + (assert-true (config? (current-config)) "is a config inside") + (assert-equal (config-ref (current-config) 'x) 42 "can read from it")) + (assert-equal (current-config) #f "restored after")))) + +;; Test 20: with-config nesting +(test "with-config nesting" + (lambda () + (let ([outer (make-config '((env . "prod")))] + [inner (make-config '((env . "test")))]) + (with-config outer + (assert-equal (config-ref (current-config) 'env) "prod" "outer") + (with-config inner + (assert-equal (config-ref (current-config) 'env) "test" "inner")) + (assert-equal (config-ref (current-config) 'env) "prod" "restored"))))) + +;; Test 21: empty config +(test "empty config" + (lambda () + (let ([cfg (make-config '())]) + (assert-true (config? cfg) "is a config") + (assert-equal (config-keys cfg) '() "no keys") + (assert-equal (config->alist cfg) '() "empty alist") + (assert-equal (config-ref/default cfg 'x 99) 99 "default for missing")))) + +;; Test 22: three-level cascading +(test "three-level cascading" + (lambda () + (let* ([grandparent (make-config '((a . 1) (b . 2) (c . 3)))] + [parent (make-config '((b . 20)) grandparent)] + [child (make-config '((c . 300)) parent)]) + (assert-equal (config-ref child 'a) 1 "from grandparent") + (assert-equal (config-ref child 'b) 20 "from parent") + (assert-equal (config-ref child 'c) 300 "from child")))) + +;; Test 23: config-merge with parents +(test "config-merge flattens both sides" + (lambda () + (let* ([p1 (make-config '((a . 1)))] + [c1 (make-config '((b . 2)) p1)] + [p2 (make-config '((c . 3)))] + [c2 (make-config '((a . 10)) p2)] + [merged (config-merge c1 c2)]) + (assert-equal (config-ref merged 'a) 10 "overridden by second") + (assert-equal (config-ref merged 'b) 2 "from first") + (assert-equal (config-ref merged 'c) 3 "from second's parent")))) + +;; Test 24: config-verify multiple errors +(test "config-verify multiple errors" + (lambda () + (let ([cfg (make-config '((port . "bad") (host . 123)))] + [schema (list (cons 'port number?) + (cons 'host string?) + (cons 'missing symbol?))]) + (let ([errors (config-verify schema cfg)]) + (assert-equal (length errors) 3 "three errors"))))) + +(newline) +(display "=========================================") (newline) +(display (format "Results: ~a/~a passed" pass-count test-count)) (newline) +(display "=========================================") (newline) +(when (< pass-count test-count) + (exit 1))