Phase 2e complete: Ecosystem (5 libraries, 113 tests passing)
ober
31f4d2dc3085c37be22143bd5da2b38c73fbeb77
new file mode 100644 --- /dev/null +++ b/lib/std/config.sls @@ -0,0 +1,273 @@ +#!chezscheme +;;; std/config.sls -- S-expression configuration with schema validation and env overrides + +(library (std config) + (export + load-config save-config config-get config-set! config-merge! + config-schema validate-config config-valid? + watch-config! config-ref config-ref* + make-config config? with-config + env-override!) + + (import (chezscheme)) + + ;; ---- Config record ---- + + (define-record-type config-rec + (fields (mutable data) (mutable schema) (mutable watchers) (mutable path)) + (protocol + (lambda (new) + (lambda (data schema path) + (new data schema '() path))))) + + (define (config? x) (config-rec? x)) + + ;; ---- make-config ---- + + (define (make-config) + (make-config-rec + (make-hashtable equal-hash equal?) + '() + #f)) + + ;; ---- Nested key access ---- + ;; Keys can be symbols or lists of symbols for nested access + ;; "APP_DB_HOST" -> (db host) + + (define (key->path k) + (cond + [(pair? k) k] + [(symbol? k) (list k)] + [(string? k) (list (string->symbol k))] + [else (error "config-key->path" "invalid key" k)])) + + (define (ht-path-get ht path) + (let loop ([h ht] [p path]) + (if (null? p) + h + (if (hashtable? h) + (let ([v (hashtable-ref h (car p) #f)]) + (if v + (loop v (cdr p)) + #f)) + #f)))) + + (define (ht-path-set! ht path val) + (if (null? (cdr path)) + (hashtable-set! ht (car path) val) + (let ([next (hashtable-ref ht (car path) #f)]) + (if (hashtable? next) + (ht-path-set! next (cdr path) val) + (let ([sub (make-hashtable equal-hash equal?)]) + (hashtable-set! ht (car path) sub) + (ht-path-set! sub (cdr path) val)))))) + + ;; ---- config-get ---- + + (define (config-get cfg key . default) + (let* ([path (key->path key)] + [v (ht-path-get (config-rec-data cfg) path)]) + (if v + v + (if (null? default) #f (car default))))) + + ;; ---- config-ref / config-ref* ---- + + (define (config-ref cfg key) + (let* ([path (key->path key)] + [v (ht-path-get (config-rec-data cfg) path)]) + (or v #f))) + + (define (config-ref* cfg . keys) + (map (lambda (k) (config-ref cfg k)) keys)) + + ;; ---- config-set! ---- + + (define (config-set! cfg key value) + (let ([path (key->path key)]) + (ht-path-set! (config-rec-data cfg) path value) + (for-each (lambda (w) (w key value)) (config-rec-watchers cfg)))) + + ;; ---- config-merge! ---- + ;; Merge an alist or hashtable into config + + (define (config-merge! cfg source) + (cond + [(hashtable? source) + (let-values ([(ks vs) (hashtable-entries source)]) + (vector-for-each + (lambda (k v) (config-set! cfg k v)) + ks vs))] + [(pair? source) + (for-each + (lambda (kv) (config-set! cfg (car kv) (cdr kv))) + source)] + [else (error "config-merge!" "invalid source type" source)])) + + ;; ---- load-config ---- + ;; Reads an S-expression from file; top level should be an alist + + (define (load-config file-path . schema) + (let ([cfg (make-config)]) + (when (not (null? schema)) + (config-rec-schema-set! cfg (car schema))) + (if (file-exists? file-path) + (begin + (config-rec-path-set! cfg file-path) + (let ([data (call-with-input-file file-path read)]) + (when (pair? data) + (config-merge! cfg data))) + ;; Apply env overrides + (env-override! cfg)) + (begin + (config-rec-path-set! cfg file-path) + (env-override! cfg))) + cfg)) + + ;; ---- save-config ---- + + (define (save-config cfg file-path) + (let ([path (or file-path (config-rec-path cfg))]) + (when path + (let-values ([(ks vs) (hashtable-entries (config-rec-data cfg))]) + (let ([alist (vector->list + (vector-map cons ks vs))]) + (call-with-output-file path + (lambda (p) (write alist p)) + 'truncate)))))) + + ;; ---- config-schema ---- + ;; Schema is a list of (key type default) triples + + (define (config-schema cfg) + (config-rec-schema cfg)) + + ;; ---- validate-config ---- + ;; Returns list of (key error-message) pairs for violations + + (define (validate-config cfg) + (let ([schema (config-rec-schema cfg)]) + (let loop ([rules schema] [errors '()]) + (if (null? rules) + (reverse errors) + (let* ([rule (car rules)] + [key (car rule)] + [type (cadr rule)] + [_ (if (pair? (cddr rule)) (caddr rule) #f)] + [val (config-get cfg key)] + [ok? (if (not val) + #t ; missing keys use defaults + (case type + [(integer int) (integer? val)] + [(string str) (string? val)] + [(boolean bool) (boolean? val)] + [(list) (list? val)] + [(symbol) (symbol? val)] + [else #t]))]) + (if ok? + (loop (cdr rules) errors) + (loop (cdr rules) + (cons (list key + (format "expected ~a, got ~s" type val)) + errors)))))))) + + (define (config-valid? cfg) + (null? (validate-config cfg))) + + ;; ---- watch-config! ---- + + (define (watch-config! cfg handler) + (config-rec-watchers-set! cfg + (cons handler (config-rec-watchers cfg)))) + + ;; ---- with-config macro ---- + ;; Binds config variables for the duration of body + + (define-syntax with-config + (syntax-rules () + [(_ cfg ([var key] ...) body ...) + (let ([var (config-get cfg 'key)] ...) + body ...)])) + + ;; ---- env-override! ---- + ;; Reads environment variables with prefix JERBOA_ (or APP_) + ;; JERBOA_DB_HOST -> key (db host) + + (define (env-override! cfg) + (let* ([prefix "JERBOA_"] + [plen (string-length prefix)] + [env-strings (get-environment-strings)]) + (for-each + (lambda (entry) + (let* ([s (car entry)] + [slen (string-length s)]) + (when (and (> slen plen) + (string=? (substring s 0 plen) prefix)) + (let* ([rest (substring s plen slen)] + [parts (string-split-char rest #\_)] + [key-path (map (lambda (p) (string->symbol (string-downcase p))) + parts)] + [val (cdr entry)]) + (ht-path-set! (config-rec-data cfg) key-path val))))) + env-strings))) + + ;; ---- string utilities ---- + + (define (string-split-char s ch) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i (string-length s)) + (reverse (cons (substring s start i) acc))] + [(char=? (string-ref s i) ch) + (loop (+ i 1) (+ i 1) (cons (substring s start i) acc))] + [else + (loop (+ i 1) start acc)]))) + + ;; Read environment variables from /proc/self/environ (NUL-separated KEY=VALUE strings) + (define (get-environment-strings) + (if (file-exists? "/proc/self/environ") + (let* ([chars (call-with-input-file "/proc/self/environ" + (lambda (p) + (let loop ([acc '()]) + (let ([c (read-char p)]) + (if (eof-object? c) + (list->string (reverse acc)) + (loop (cons c acc)))))))] + ;; Split on NUL + [entries (let split ([i 0] [start 0] [acc '()]) + (if (= i (string-length chars)) + (if (= start i) + (reverse acc) + (reverse (cons (substring chars start i) acc))) + (if (char=? (string-ref chars i) (integer->char 0)) + (split (+ i 1) (+ i 1) + (if (= start i) acc + (cons (substring chars start i) acc))) + (split (+ i 1) start acc))))]) + (filter-map + (lambda (s) + (let ([eq-pos (string-index s #\=)]) + (if eq-pos + (cons (substring s 0 eq-pos) + (substring s (+ eq-pos 1) (string-length s))) + #f))) + entries)) + '())) + + (define (string-index s ch) + (let loop ([i 0]) + (cond + [(= i (string-length s)) #f] + [(char=? (string-ref s i) ch) i] + [else (loop (+ i 1))]))) + + (define (filter-map f lst) + (let loop ([l lst] [acc '()]) + (if (null? l) + (reverse acc) + (let ([v (f (car l))]) + (if v + (loop (cdr l) (cons v acc)) + (loop (cdr l) acc)))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/doc/generator.sls @@ -0,0 +1,270 @@ +#!chezscheme +;;; std/doc/generator.sls -- Documentation generator from docstring comments + +(library (std doc generator) + (export + extract-docs generate-markdown generate-html + make-doc-entry doc-entry-name doc-entry-type doc-entry-doc doc-entry-examples + parse-docstring format-signature + doc-module doc-procedure doc-syntax doc-value + write-docs) + + (import (chezscheme)) + + ;; ---- Doc entry record ---- + + (define-record-type doc-entry + (fields name type doc examples signature) + (protocol + (lambda (new) + (lambda (name type doc examples . sig) + (new name type doc examples (if (null? sig) #f (car sig))))))) + + ;; ---- Doc type constructors (return doc-entry) ---- + + (define (doc-module name doc . examples) + (make-doc-entry name 'module doc examples)) + + (define (doc-procedure name sig doc . examples) + (make-doc-entry name 'procedure doc examples sig)) + + (define (doc-syntax name sig doc . examples) + (make-doc-entry name 'syntax doc examples sig)) + + (define (doc-value name doc . examples) + (make-doc-entry name 'value doc examples)) + + ;; ---- format-signature ---- + + (define (format-signature entry) + (let ([sig (doc-entry-signature entry)] + [name (doc-entry-name entry)]) + (if sig + (format "(~a ~a)" name sig) + (format "~a" name)))) + + ;; ---- parse-docstring ---- + ;; Parses a string looking for "Doc: ..." lines, "Example: ..." lines + ;; Returns an association list: ((doc . "...") (examples . ("..." ...))) + + (define (parse-docstring text) + (let ([lines (string-split-lines text)]) + (let loop ([ls lines] [doc-lines '()] [examples '()] [in-doc #f]) + (if (null? ls) + (list (cons 'doc (string-join (reverse doc-lines) "\n")) + (cons 'examples (reverse examples))) + (let ([line (string-trim (car ls))]) + (cond + [(string-prefix? "Doc:" line) + (loop (cdr ls) + (cons (string-trim (substring line 4 (string-length line))) + doc-lines) + examples #t)] + [(string-prefix? ";; Doc:" line) + (let ([txt (string-trim (substring line 7 (string-length line)))]) + (loop (cdr ls) (cons txt doc-lines) examples #t))] + [(string-prefix? "Example:" line) + (let ([ex (string-trim (substring line 8 (string-length line)))]) + (loop (cdr ls) doc-lines (cons ex examples) in-doc))] + [(string-prefix? ";; Example:" line) + (let ([ex (string-trim (substring line 11 (string-length line)))]) + (loop (cdr ls) doc-lines (cons ex examples) in-doc))] + [else + (loop (cdr ls) doc-lines examples in-doc)])))))) + + ;; ---- String utilities ---- + + (define (string-split-lines s) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(= i (string-length s)) + (reverse (cons (substring s start i) acc))] + [(char=? (string-ref s i) #\newline) + (loop (+ i 1) (+ i 1) (cons (substring s start i) acc))] + [else + (loop (+ i 1) start acc)]))) + + (define (string-trim s) + (let ([len (string-length s)]) + (let lloop ([start 0]) + (if (and (< start len) (char-whitespace? (string-ref s start))) + (lloop (+ start 1)) + (let rloop ([end len]) + (if (and (> end start) (char-whitespace? (string-ref s (- end 1)))) + (rloop (- end 1)) + (substring s start end))))))) + + (define (string-prefix? prefix s) + (and (>= (string-length s) (string-length prefix)) + (string=? (substring s 0 (string-length prefix)) prefix))) + + (define (string-join strs sep) + (if (null? strs) + "" + (fold-left (lambda (acc s) (string-append acc sep s)) + (car strs) + (cdr strs)))) + + ;; ---- HTML escaping ---- + + (define (html-escape s) + (let loop ([i 0] [acc '()]) + (if (= i (string-length s)) + (apply string-append (reverse acc)) + (let ([c (string-ref s i)]) + (loop (+ i 1) + (cons (case c + [(#\<) "<"] + [(#\>) ">"] + [(#\&) "&"] + [(#\") """] + [else (string c)]) + acc)))))) + + ;; ---- extract-docs ---- + ;; Reads a source file and extracts doc entries from `;; Doc:` comment blocks + ;; Returns a list of doc-entry records + + (define (extract-docs file-path) + (if (file-exists? file-path) + (let ([text (call-with-input-file file-path + (lambda (p) (read-string-all p)))]) + (extract-from-text text)) + '())) + + (define (read-string-all port) + (let loop ([acc '()]) + (let ([c (read-char port)]) + (if (eof-object? c) + (list->string (reverse acc)) + (loop (cons c acc)))))) + + ;; Parse doc entries from text + (define (extract-from-text text) + (let ([lines (string-split-lines text)]) + (let loop ([ls lines] [acc '()] [current-doc #f] [current-name #f] [current-type #f]) + (if (null? ls) + (reverse acc) + (let ([line (string-trim (car ls))]) + (cond + ;; Start of doc block: ;; Doc: name (type): description + [(and (string-prefix? ";; Doc:" line)) + (let* ([rest (string-trim (substring line 7 (string-length line)))] + [parsed (parse-doc-header rest)]) + (if parsed + (loop (cdr ls) acc + (cadr parsed) (car parsed) (caddr parsed)) + (loop (cdr ls) acc rest #f 'procedure)))] + ;; Additional doc lines + [(and current-name (string-prefix? ";;" line) (not (string=? line ";;"))) + (let ([more (string-trim (substring line 2 (string-length line)))]) + (loop (cdr ls) acc + (if current-doc + (string-append current-doc " " more) + more) + current-name current-type))] + ;; Blank comment or non-comment ends block, emit entry + [else + (let ([new-acc (if current-name + (cons (make-doc-entry current-name + (or current-type 'value) + (or current-doc "") + '()) + acc) + acc)]) + (loop (cdr ls) new-acc #f #f #f))])))))) + + (define (parse-doc-header text) + ;; "name (type): doc..." -> (name doc type) + ;; Find first space to get name, then look for (type) qualifier + (let* ([len (string-length text)] + [sp (let scan ([i 0]) + (if (or (= i len) (char=? (string-ref text i) #\space)) + i + (scan (+ i 1))))]) + (if (= sp len) + ;; No space: whole text is name + (list text "" 'procedure) + (let* ([name (substring text 0 sp)] + [rest (string-trim (substring text sp len))] + [rlen (string-length rest)]) + (if (and (> rlen 0) (char=? (string-ref rest 0) (integer->char 40))) + ;; Has (type) qualifier + (let find-close ([j 1]) + (cond + [(= j rlen) + (list name "" 'procedure)] + [(char=? (string-ref rest j) (integer->char 41)) + (let* ([type-str (substring rest 1 j)] + [type (string->symbol type-str)] + [doc-rest (if (< (+ j 1) rlen) + (string-trim (substring rest (+ j 1) rlen)) + "")]) + (list name doc-rest type))] + [else + (find-close (+ j 1))])) + ;; No (type): rest is the doc + (list name rest 'procedure)))))) + + ;; ---- generate-markdown ---- + + (define (generate-markdown entries) + (let ([out (open-output-string)]) + (for-each + (lambda (entry) + (let ([name (doc-entry-name entry)] + [type (doc-entry-type entry)] + [doc (doc-entry-doc entry)] + [exs (doc-entry-examples entry)]) + (display (format "## `~a`\n\n" name) out) + (display (format "**Type:** ~a\n\n" type) out) + (display (format "~a\n\n" doc) out) + (unless (null? exs) + (display "**Examples:**\n\n" out) + (for-each + (lambda (ex) + (display (format "```scheme\n~a\n```\n\n" ex) out)) + exs)))) + entries) + (get-output-string out))) + + ;; ---- generate-html ---- + + (define (generate-html entries) + (let ([out (open-output-string)]) + (display "<!DOCTYPE html>\n<html>\n<head>\n" out) + (display "<meta charset=\"UTF-8\">\n" out) + (display "<style>body{font-family:monospace;max-width:800px;margin:auto;padding:2em}</style>\n" out) + (display "</head>\n<body>\n" out) + (for-each + (lambda (entry) + (let ([name (doc-entry-name entry)] + [type (doc-entry-type entry)] + [doc (doc-entry-doc entry)] + [exs (doc-entry-examples entry)]) + (display (format "<section>\n<h2><code>~a</code></h2>\n" (html-escape name)) out) + (display (format "<p><strong>Type:</strong> ~a</p>\n" type) out) + (display (format "<p>~a</p>\n" (html-escape doc)) out) + (unless (null? exs) + (display "<p><strong>Examples:</strong></p>\n" out) + (for-each + (lambda (ex) + (display (format "<pre><code>~a</code></pre>\n" (html-escape ex)) out)) + exs)) + (display "</section>\n" out))) + entries) + (display "</body>\n</html>\n" out) + (get-output-string out))) + + ;; ---- write-docs ---- + + (define (write-docs entries output-file format) + (let ([content (case format + [(markdown md) (generate-markdown entries)] + [(html) (generate-html entries)] + [else (generate-markdown entries)])]) + (call-with-output-file output-file + (lambda (p) (display content p)) + 'truncate))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/ds/sorted-map.sls @@ -0,0 +1,328 @@ +#!chezscheme +;;; std/ds/sorted-map.sls -- Persistent sorted map using red-black trees + +(library (std ds sorted-map) + (export + sorted-map-empty sorted-map? sorted-map-size + sorted-map-insert sorted-map-lookup sorted-map-delete + sorted-map-min sorted-map-max + sorted-map-fold sorted-map->alist alist->sorted-map + sorted-map-keys sorted-map-values + sorted-map-range + make-sorted-map) + + (import (chezscheme)) + + ;; ---- Red-Black Tree Representation ---- + ;; Node: #(color key value left right) + ;; color: 'R (red) or 'B (black) + ;; Empty: #f + + (define *empty* #f) + + (define (node-color n) (vector-ref n 0)) + (define (node-key n) (vector-ref n 1)) + (define (node-value n) (vector-ref n 2)) + (define (node-left n) (vector-ref n 3)) + (define (node-right n) (vector-ref n 4)) + + (define (make-node color key value left right) + (vector color key value left right)) + + (define (red? n) (and n (eq? (node-color n) 'R))) + (define (black? n) (or (not n) (eq? (node-color n) 'B))) + + ;; ---- Sorted map record ---- + ;; Wraps the tree root + comparator + size + + (define-record-type sorted-map-rec + (fields root cmp size) + (protocol + (lambda (new) + (lambda (root cmp size) + (new root cmp size))))) + + (define (sorted-map? x) (sorted-map-rec? x)) + + ;; ---- sorted-map-empty ---- + + (define (sorted-map-empty) + (make-sorted-map-rec *empty* default-cmp 0)) + + (define (make-sorted-map cmp) + (make-sorted-map-rec *empty* cmp 0)) + + ;; ---- Default comparator ---- + + (define (default-cmp a b) + (cond + [(and (number? a) (number? b)) + (cond [(< a b) -1] [(> a b) 1] [else 0])] + [(and (string? a) (string? b)) + (cond [(string<? a b) -1] [(string>? a b) 1] [else 0])] + [(and (symbol? a) (symbol? b)) + (let ([sa (symbol->string a)] [sb (symbol->string b)]) + (cond [(string<? sa sb) -1] [(string>? sa sb) 1] [else 0]))] + [else + (let ([sa (format "~s" a)] [sb (format "~s" b)]) + (cond [(string<? sa sb) -1] [(string>? sa sb) 1] [else 0]))])) + + ;; ---- Balance ---- + ;; Standard Okasaki balance cases for left-leaning RB trees + + (define (balance color key value left right) + (cond + ;; Case 1: left-left + [(and (eq? color 'B) + (red? left) + (red? (node-left left))) + (make-node 'R + (node-key left) + (node-value left) + (make-node 'B + (node-key (node-left left)) + (node-value (node-left left)) + (node-left (node-left left)) + (node-right (node-left left))) + (make-node 'B key value (node-right left) right))] + ;; Case 2: left-right + [(and (eq? color 'B) + (red? left) + (red? (node-right left))) + (make-node 'R + (node-key (node-right left)) + (node-value (node-right left)) + (make-node 'B + (node-key left) + (node-value left) + (node-left left) + (node-left (node-right left))) + (make-node 'B key value + (node-right (node-right left)) + right))] + ;; Case 3: right-left + [(and (eq? color 'B) + (red? right) + (red? (node-left right))) + (make-node 'R + (node-key (node-left right)) + (node-value (node-left right)) + (make-node 'B key value left + (node-left (node-left right))) + (make-node 'B + (node-key right) + (node-value right) + (node-right (node-left right)) + (node-right right)))] + ;; Case 4: right-right + [(and (eq? color 'B) + (red? right) + (red? (node-right right))) + (make-node 'R + (node-key right) + (node-value right) + (make-node 'B key value left (node-left right)) + (make-node 'B + (node-key (node-right right)) + (node-value (node-right right)) + (node-left (node-right right)) + (node-right (node-right right))))] + ;; Default + [else + (make-node color key value left right)])) + + ;; ---- sorted-map-insert ---- + + (define (sorted-map-insert sm key value) + (let* ([cmp (sorted-map-rec-cmp sm)] + [root (sorted-map-rec-root sm)] + [found? #f] + [new-root (ins root key value cmp found?)]) + ;; Make root black + (let ([black-root (make-node 'B + (node-key new-root) + (node-value new-root) + (node-left new-root) + (node-right new-root))]) + ;; We need to know if key was already present to track size + ;; Use a simpler approach: check membership first + (let ([exists? (sorted-map-lookup sm key)]) + (make-sorted-map-rec + black-root + cmp + (if exists? + (sorted-map-rec-size sm) + (+ (sorted-map-rec-size sm) 1))))))) + + (define (ins node key value cmp found) + (if (not node) + (make-node 'R key value *empty* *empty*) + (let ([c (cmp key (node-key node))]) + (cond + [(< c 0) + (balance (node-color node) + (node-key node) + (node-value node) + (ins (node-left node) key value cmp found) + (node-right node))] + [(> c 0) + (balance (node-color node) + (node-key node) + (node-value node) + (node-left node) + (ins (node-right node) key value cmp found))] + [else + ;; Key exists: update value + (make-node (node-color node) key value + (node-left node) (node-right node))])))) + + ;; ---- sorted-map-lookup ---- + + (define (sorted-map-lookup sm key) + (let ([cmp (sorted-map-rec-cmp sm)]) + (let search ([node (sorted-map-rec-root sm)]) + (if (not node) + #f + (let ([c (cmp key (node-key node))]) + (cond + [(< c 0) (search (node-left node))] + [(> c 0) (search (node-right node))] + [else (node-value node)])))))) + + ;; ---- sorted-map-size ---- + + (define (sorted-map-size sm) + (sorted-map-rec-size sm)) + + ;; ---- sorted-map-min / sorted-map-max ---- + + (define (sorted-map-min sm) + (let loop ([node (sorted-map-rec-root sm)] [prev #f]) + (if (not node) + prev + (loop (node-left node) (cons (node-key node) (node-value node)))))) + + (define (sorted-map-max sm) + (let loop ([node (sorted-map-rec-root sm)] [prev #f]) + (if (not node) + prev + (loop (node-right node) (cons (node-key node) (node-value node)))))) + + ;; ---- sorted-map-fold ---- + ;; In-order traversal: (proc key value acc) -> acc + + (define (sorted-map-fold sm proc init) + (let traverse ([node (sorted-map-rec-root sm)] [acc init]) + (if (not node) + acc + (let* ([left-acc (traverse (node-left node) acc)] + [mid-acc (proc (node-key node) (node-value node) left-acc)]) + (traverse (node-right node) mid-acc))))) + + ;; ---- sorted-map->alist ---- + + (define (sorted-map->alist sm) + (reverse (sorted-map-fold sm + (lambda (k v acc) (cons (cons k v) acc)) + '()))) + + ;; ---- alist->sorted-map ---- + + (define (alist->sorted-map alist . cmp-arg) + (let ([sm (if (null? cmp-arg) + (sorted-map-empty) + (make-sorted-map (car cmp-arg)))]) + (fold-left + (lambda (m kv) (sorted-map-insert m (car kv) (cdr kv))) + sm + alist))) + + ;; ---- sorted-map-keys / sorted-map-values ---- + + (define (sorted-map-keys sm) + (reverse (sorted-map-fold sm (lambda (k v acc) (cons k acc)) '()))) + + (define (sorted-map-values sm) + (reverse (sorted-map-fold sm (lambda (k v acc) (cons v acc)) '()))) + + ;; ---- sorted-map-delete ---- + ;; Deletion from RB tree (using standard algorithm) + + (define (sorted-map-delete sm key) + (let* ([cmp (sorted-map-rec-cmp sm)] + [root (sorted-map-rec-root sm)]) + (if (not (sorted-map-lookup sm key)) + sm ; Key not found, return unchanged + (let ([new-root (rb-delete root key cmp)]) + (let ([black-root (if new-root + (make-node 'B + (node-key new-root) + (node-value new-root) + (node-left new-root) + (node-right new-root)) + *empty*)]) + (make-sorted-map-rec + black-root + cmp + (- (sorted-map-rec-size sm) 1))))))) + + ;; Simple delete using rebuild approach + (define (rb-delete node key cmp) + (if (not node) + *empty* + (let ([c (cmp key (node-key node))]) + (cond + [(< c 0) + (let ([new-left (rb-delete (node-left node) key cmp)]) + (balance (node-color node) + (node-key node) + (node-value node) + new-left + (node-right node)))] + [(> c 0) + (let ([new-right (rb-delete (node-right node) key cmp)]) + (balance (node-color node) + (node-key node) + (node-value node) + (node-left node) + new-right))] + [else + ;; Found the node to delete + (let ([left (node-left node)] + [right (node-right node)]) + (cond + [(not left) right] + [(not right) left] + [else + ;; Replace with in-order successor (leftmost of right subtree) + (let-values ([(succ-key succ-val new-right) (extract-min right)]) + (balance (node-color node) + succ-key succ-val + left + new-right))]))])))) + + (define (extract-min node) + (if (not (node-left node)) + (values (node-key node) (node-value node) (node-right node)) + (let-values ([(k v new-left) (extract-min (node-left node))]) + (values k v + (balance (node-color node) + (node-key node) + (node-value node) + new-left + (node-right node)))))) + + ;; ---- sorted-map-range ---- + ;; Returns new sorted-map with only keys in [lo, hi] + + (define (sorted-map-range sm lo hi) + (let ([cmp (sorted-map-rec-cmp sm)]) + (sorted-map-fold sm + (lambda (k v acc) + (if (and (>= (cmp k lo) 0) + (<= (cmp k hi) 0)) + (sorted-map-insert acc k v) + acc)) + (make-sorted-map cmp)))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/net/grpc.sls @@ -0,0 +1,274 @@ +#!chezscheme +;;; std/net/grpc.sls -- gRPC-style RPC over TCP using S-expressions as wire format +;;; +;;; Protocol: client sends (method arg ...) as an S-expression followed by newline. +;;; Server responds with (ok result) or (error message). +;;; Length-prefix framing is not needed since `read` handles S-expression boundaries. + +(library (std net grpc) + (export + define-service define-rpc + make-grpc-server grpc-server-start! grpc-server-stop! grpc-server-port + make-grpc-client grpc-call grpc-call-async + grpc-status grpc-ok? grpc-error? + with-grpc-client) + + (import (chezscheme)) + + ;; ---- C socket FFI ---- + + (define *libc-loaded* #f) + + (define (ensure-libc!) + (unless *libc-loaded* + (load-shared-object "libc.so.6") + (set! *libc-loaded* #t))) + + (define (get-socket-fn) (foreign-procedure "socket" (int int int) int)) + (define (get-bind-fn) (foreign-procedure "bind" (int u8* int) int)) + (define (get-listen-fn) (foreign-procedure "listen" (int int) int)) + (define (get-accept-fn) (foreign-procedure "accept" (int u8* u32*) int)) + (define (get-connect-fn) (foreign-procedure "connect" (int u8* int) int)) + (define (get-close-fn) (foreign-procedure "close" (int) int)) + (define (get-dup-fn) (foreign-procedure "dup" (int) int)) + (define (get-setsockopt-fn) (foreign-procedure "setsockopt" (int int int u8* int) int)) + + (define AF_INET 2) + (define SOCK_STREAM 1) + (define SOL_SOCKET 1) + (define SO_REUSEADDR 2) + + (define (make-sockaddr port h0 h1 h2 h3) + (let ([bv (make-bytevector 16 0)]) + (bytevector-u8-set! bv 0 AF_INET) + (bytevector-u8-set! bv 2 (quotient port 256)) + (bytevector-u8-set! bv 3 (remainder port 256)) + (bytevector-u8-set! bv 4 h0) + (bytevector-u8-set! bv 5 h1) + (bytevector-u8-set! bv 6 h2) + (bytevector-u8-set! bv 7 h3) + bv)) + + ;; Create separate input/output ports from a socket fd + (define (fd->ports fd) + (let* ([c-dup (get-dup-fn)] + [fd2 (c-dup fd)] + [inp (open-fd-input-port fd (buffer-mode block) (native-transcoder))] + [out (open-fd-output-port fd2 (buffer-mode block) (native-transcoder))]) + (cons inp out))) + + ;; ---- gRPC Status ---- + + (define-record-type grpc-status-rec + (fields ok? code message data) + (protocol + (lambda (new) + (lambda (ok? code message . data) + (new ok? code message (if (null? data) #f (car data))))))) + + (define (grpc-status ok? code message . data) + (apply make-grpc-status-rec ok? code message data)) + + (define (grpc-ok? s) (grpc-status-rec-ok? s)) + (define (grpc-error? s) (not (grpc-status-rec-ok? s))) + + ;; ---- Service registry ---- + + ;; A "service" is a hashtable from symbol -> procedure + ;; Global service registry + (define *service-registry* (make-hashtable equal-hash equal?)) + + (define-syntax define-service + (syntax-rules () + [(_ service-name) + (define service-name (make-hashtable equal-hash equal?))])) + + (define-syntax define-rpc + (syntax-rules () + [(_ service-name method-name handler) + (hashtable-set! service-name 'method-name handler)])) + + ;; ---- gRPC Server ---- + + (define-record-type grpc-server-rec + (fields (mutable socket-fd) + (mutable running?) + (mutable port-number) + (mutable thread) + services) + (protocol + (lambda (new) + (lambda (port services) + (new -1 #f port #f services))))) + + (define (grpc-server-port srv) (grpc-server-rec-port-number srv)) + + (define (make-grpc-server port . services) + (let ([svc (if (null? services) + (make-hashtable equal-hash equal?) + (car services))]) + (make-grpc-server-rec port svc))) + + (define (grpc-server-start! srv) + (ensure-libc!) + (let ([c-socket (get-socket-fn)] + [c-bind (get-bind-fn)] + [c-listen (get-listen-fn)] + [c-setsockopt (get-setsockopt-fn)] + [c-accept (get-accept-fn)] + [c-close (get-close-fn)] + [port (grpc-server-rec-port-number srv)]