Implement final 4 TODO items: match2 prelude, registry, LSP, protobuf
ober
1280b611d63d9a6c01e9637bb550d56e8875664a
--- a/bin/jerboa +++ b/bin/jerboa @@ -34,6 +34,10 @@ Commands: eval '<expr>' Evaluate a single expression test [dir] Discover and run test files (default: tests/) build Run make build in the project directory + install <gh-url> Install a package (e.g. github.com/user/repo) + uninstall <name> Uninstall a package by name + update [name] Update one or all installed packages + list List installed packages version Print version info help Print this help message @@ -121,6 +125,90 @@ cmd_build() { exec make -C "$JERBOA_HOME" build } +cmd_install() { + if [ $# -eq 0 ]; then + echo "Error: jerboa install requires a GitHub path" >&2 + echo "Usage: jerboa install github.com/user/repo" >&2 + exit 1 + fi + local gh_path="$1" + "$SCHEME" --libdirs "$LIBDIRS" --program <(cat <<INSTALL +(import (jerboa registry)) +(let ([entry (package-install! "$gh_path")]) + (display "Installed: ") + (display "$gh_path") + (newline)) +INSTALL + ) +} + +cmd_uninstall() { + if [ $# -eq 0 ]; then + echo "Error: jerboa uninstall requires a package name" >&2 + echo "Usage: jerboa uninstall <package-name>" >&2 + exit 1 + fi + local name="$1" + "$SCHEME" --libdirs "$LIBDIRS" --program <(cat <<UNINSTALL +(import (jerboa registry)) +(package-uninstall! "$name") +(display "Uninstalled: ") +(display "$name") +(newline) +UNINSTALL + ) +} + +cmd_update() { + if [ $# -eq 0 ]; then + # Update all packages + "$SCHEME" --libdirs "$LIBDIRS" --program <(cat <<'UPDATEALL' +(import (except (chezscheme) make-hash-table hash-table? iota 1+ 1-) + (jerboa runtime) + (jerboa registry)) +(let ([pkgs (installed-packages)]) + (if (null? pkgs) + (display "No packages installed.\n") + (for-each + (lambda (e) + (let ([name (hash-ref e "name" "")]) + (display (string-append "Updating " name "...\n")) + (package-update! name))) + pkgs))) +UPDATEALL + ) + else + local name="$1" + "$SCHEME" --libdirs "$LIBDIRS" --program <(cat <<UPDATE +(import (jerboa registry)) +(package-update! "$name") +(display "Updated: ") +(display "$name") +(newline) +UPDATE + ) + fi +} + +cmd_list() { + "$SCHEME" --libdirs "$LIBDIRS" --program <(cat <<'LIST' +(import (except (chezscheme) make-hash-table hash-table? iota 1+ 1-) + (jerboa runtime) + (jerboa registry)) +(let ([pkgs (installed-packages)]) + (if (null? pkgs) + (display "No packages installed.\n") + (for-each + (lambda (e) + (let ([name (hash-ref e "name" "")] + [ver (hash-ref e "version" "?")] + [url (hash-ref e "url" "")]) + (display (string-append " " name " (" ver ") — " url "\n")))) + pkgs))) +LIST + ) +} + cmd_version() { echo "jerboa $VERSION" echo "home: $JERBOA_HOME" @@ -148,6 +236,21 @@ case "${1:-}" in build) cmd_build ;; + install) + shift + cmd_install "$@" + ;; + uninstall) + shift + cmd_uninstall "$@" + ;; + update) + shift + cmd_update "$@" + ;; + list) + cmd_list + ;; version|--version|-v) cmd_version ;; --- a/docs/TODO.md +++ b/docs/TODO.md @@ -45,56 +45,18 @@ or completed in the March 2026 sprint. Remaining items are genuinely open. - [x] **Import conflict reference** — `docs/import-conflicts.md` - [x] **API reference generator** — `tools/gen-api-docs.ss` +- [x] **Struct patterns in prelude match** — `(jerboa prelude)` now re-exports `(std match2)`'s `match` with struct patterns, sealed hierarchies, active patterns, and `match/strict` +- [x] **Package registry** — `(jerboa registry)` with GitHub-based install/uninstall/update; `bin/jerboa install/uninstall/update/list` CLI commands +- [x] **LSP server** — `(std lsp server)` + `(std lsp symbols)` with JSON-RPC over stdio; `tools/jerboa-lsp.ss` entry point; completion, hover, go-to-definition, diagnostics +- [x] **Protocol Buffers** — `(std protobuf)` wire format encoder/decoder (proto3); varint, fixed32/64, length-delimited, zigzag, embedded messages + --- ## Remaining -### 2.2 Struct Patterns in Core Match (Decision Needed) - -**Severity: Medium | Effort: Small** - -`(std match2)` has full struct matching but is separate from the prelude's -core `match`. Options: - -1. Re-export `match2`'s `match` from the prelude (breaking change — needs assessment) -2. Upgrade core `match` with struct support -3. Keep as-is and document prominently (current state — docs/quickstart.md covers this) - -Decision: currently documented in quickstart. May upgrade prelude later. - -### 4.1 Package Registry - -**Severity: Medium | Effort: Large** - -`(jerboa pkg)` and `(jerboa lock)` handle versioning and lockfiles, but -there is no **registry** — no way to discover or install packages by name. -Options: - -- GitHub-based (like early Go): `jerboa install github.com/user/pkg` -- Central registry (like crates.io): more discovery, more infrastructure -- Git-submodule approach: zero infrastructure needed - -### 4.3 Editor Integration / LSP - -**Severity: Medium | Effort: Large** - -No LSP server exists. A basic one providing: -- Go-to-definition (using `(std doc)` data) -- Completion from module exports -- Hover documentation -- Error diagnostics - -Would significantly improve the development experience. Could be written -in Jerboa itself using the REPL server infrastructure. - ### Networking Polish - **SOCKS proxy** — low priority - **HTTP client API compat** — header format differences vs Gerbil (dotted pairs vs triples). `(std net request)` works but Gerbil ports need header conversion. - -### Protocol Buffers - -`(std protobuf)` — Google's serialization format. Lower priority than -TOML/MessagePack/CBOR (which are now done) but useful for gRPC interop. --- a/lib/jerboa/prelude.sls +++ b/lib/jerboa/prelude.sls @@ -12,7 +12,8 @@ ;; ---- Core macros ---- def def* defrule defrules defstruct defclass defmethod - match + match match/strict + define-match-type define-sealed-hierarchy define-active-pattern try catch finally while until @@ -95,7 +96,17 @@ path-extension path-absolute? with-input-from-string with-output-to-string iota 1+ 1-) - (jerboa core) + (only (jerboa core) + def def* defrule defrules + defstruct defclass defmethod + try catch finally + while until + hash-literal hash-eq-literal + let-hash) + (only (std match2) + match match/strict + define-match-type define-sealed-hierarchy define-active-pattern) + (jerboa runtime) (jerboa ffi) (std sort) (std format) --- a/lib/jerboa/prelude/clean.sls +++ b/lib/jerboa/prelude/clean.sls @@ -18,7 +18,8 @@ ;; ---- Core macros ---- def def* defrule defrules defstruct defclass defmethod - match + match match/strict + define-match-type define-sealed-hierarchy define-active-pattern try catch finally while until hash-literal hash-eq-literal @@ -93,11 +94,13 @@ (only (jerboa core) def def* defrule defrules defstruct defclass defmethod - match try catch finally while until hash-literal hash-eq-literal let-hash) + (only (std match2) + match match/strict + define-match-type define-sealed-hierarchy define-active-pattern) (only (jerboa runtime) ~ bind-method! call-method make-hash-table-eq new file mode 100644 --- /dev/null +++ b/lib/jerboa/registry.sls @@ -0,0 +1,169 @@ +#!chezscheme +;;; (jerboa registry) — GitHub-based package registry (no central server). +;;; Packages identified by github.com/user/repo, installed via git clone. + +(library (jerboa registry) + (export registry-search registry-lookup + package-install! package-uninstall! package-update! + installed-packages package-installed? + *registry-file* *package-dir*) + (import (except (chezscheme) make-hash-table hash-table? iota 1+ 1-) + (jerboa runtime) + (std text json)) + + (define (home-dir) + (or (getenv "HOME") (error 'registry "HOME not set"))) + + (define *registry-file* + (make-parameter (string-append (home-dir) "/.jerboa/registry.json"))) + + (define *package-dir* + (make-parameter (string-append (home-dir) "/.jerboa/packages/"))) + + (define (ensure-directory path) + (unless (file-exists? path) + (system (string-append "mkdir -p " (shell-quote path))))) + + (define (shell-quote s) + (string-append "'" (let loop ([i 0] [acc ""]) + (if (= i (string-length s)) + acc + (let ([ch (string-ref s i)]) + (if (char=? ch #\') + (loop (+ i 1) (string-append acc "'\\''")) + (loop (+ i 1) (string-append acc (string ch))))))) "'")) + + (define (run-command cmd) + (let ([rc (system cmd)]) + (unless (= rc 0) + (error 'registry "command failed" cmd rc)))) + + (define (url-from-github-path gh-path) + (string-append "https://" gh-path ".git")) + + (define (name-from-github-path gh-path) + (let loop ([i (- (string-length gh-path) 1)]) + (cond + [(< i 0) gh-path] + [(char=? (string-ref gh-path i) #\/) + (substring gh-path (+ i 1) (string-length gh-path))] + [else (loop (- i 1))]))) + + (define (current-date-string) + (let ([t (current-date)]) + (format "~a-~2,'0d-~2,'0d" + (date-year t) (date-month t) (date-day t)))) + + (define (load-registry) + (let ([file (*registry-file*)]) + (if (file-exists? file) + (let ([data (call-with-input-file file + (lambda (p) (read-json p)))]) + (if (list? data) data '())) + '()))) + + (define (save-registry! entries) + (ensure-directory (path-parent (*registry-file*))) + (call-with-output-file (*registry-file*) + (lambda (p) (write-json entries p) (newline p)) + 'replace)) + + (define (path-parent path) + (let loop ([i (- (string-length path) 1)]) + (cond + [(< i 0) "."] + [(char=? (string-ref path i) #\/) (substring path 0 i)] + [else (loop (- i 1))]))) + + ;; Entry accessors — each entry is a hashtable with string keys + (define (entry-name e) (hash-ref e "name" "")) + (define (entry-version e) (hash-ref e "version" "0.0.0")) + (define (entry-path e) (hash-ref e "path" "")) + (define (entry-url e) (hash-ref e "url" "")) + (define (entry-date e) (hash-ref e "installed-date" "")) + + (define (make-entry name version path url date) + (let ([ht (make-hash-table)]) + (hash-put! ht "name" name) + (hash-put! ht "version" version) + (hash-put! ht "path" path) + (hash-put! ht "url" url) + (hash-put! ht "installed-date" date) + ht)) + + (define (read-pkg-version pkg-dir) + (let ([pkg-file (string-append pkg-dir "/jerboa.pkg")]) + (if (file-exists? pkg-file) + (guard (e [#t "0.0.0"]) + (let ([data (call-with-input-file pkg-file read)]) + (if (list? data) + (let loop ([lst data]) + (cond + [(null? lst) "0.0.0"] + [(and (pair? (car lst)) + (eq? (caar lst) 'version)) + (let ([v (cdar lst)]) + (if (pair? v) (car v) (cdr (car lst))))] + [else (loop (cdr lst))])) + "0.0.0"))) + "0.0.0"))) + + (define (registry-search query) + (let ([entries (load-registry)] + [q (string-downcase query)]) + (filter (lambda (e) + (string-contains (string-downcase (entry-name e)) q)) + entries))) + + (define (string-contains haystack needle) + (let ([hlen (string-length haystack)] + [nlen (string-length needle)]) + (let loop ([i 0]) + (cond + [(> (+ i nlen) hlen) #f] + [(string=? (substring haystack i (+ i nlen)) needle) #t] + [else (loop (+ i 1))])))) + + (define (registry-lookup name) + (let ([entries (load-registry)]) + (find (lambda (e) (string=? (entry-name e) name)) entries))) + + (define (package-install! gh-path) + (let* ([name (name-from-github-path gh-path)] + [url (url-from-github-path gh-path)] + [dest (string-append (*package-dir*) name)]) + (when (package-installed? name) + (error 'package-install! "package already installed" name)) + (ensure-directory (*package-dir*)) + (run-command (string-append "git clone " (shell-quote url) + " " (shell-quote dest))) + (let* ([version (read-pkg-version dest)] + [entry (make-entry name version dest gh-path + (current-date-string))] + [entries (load-registry)]) + (save-registry! (cons entry entries)) + entry))) + + (define (package-uninstall! name) + (let ([entry (registry-lookup name)]) + (unless entry + (error 'package-uninstall! "package not installed" name)) + (let ([path (entry-path entry)]) + (when (file-exists? path) + (run-command (string-append "rm -rf " (shell-quote path))))) + (save-registry! + (filter (lambda (e) (not (string=? (entry-name e) name))) + (load-registry))))) + + (define (package-update! name) + (let ([entry (registry-lookup name)]) + (unless entry + (error 'package-update! "package not installed" name)) + (let ([path (entry-path entry)]) + (run-command (string-append "git -C " (shell-quote path) " pull"))))) + + (define (installed-packages) (load-registry)) + + (define (package-installed? name) (and (registry-lookup name) #t)) + +) new file mode 100644 --- /dev/null +++ b/lib/std/lsp/server.sls @@ -0,0 +1,262 @@ +#!chezscheme +;;; :std/lsp/server -- Minimal LSP server over stdio (JSON-RPC 2.0) + +(library (std lsp server) + (export start-lsp-server handle-request + lsp-respond lsp-notify make-lsp-state lsp-state?) + (import (chezscheme) (std text json) (std lsp symbols)) + + (define-record-type lsp-state + (fields (mutable files) ;; uri-string -> text-string + (mutable root-path) ;; string or #f + (mutable shutdown?)) ;; boolean + (protocol + (lambda (new) + (lambda () (new (make-hashtable string-hash string=?) #f #f))))) + + ;; ---- JSON-RPC message I/O ---- + + (define (read-header port) + (let loop ([content-length #f]) + (let ([line (get-line port)]) + (cond + [(eof-object? line) #f] + [(or (string=? line "") (string=? line "\r")) content-length] + [else (loop (or (parse-content-length line) content-length))])))) + + (define (parse-content-length line) + (let ([prefix "Content-Length: "]) + (and (>= (string-length line) (string-length prefix)) + (string=? prefix (substring line 0 (string-length prefix))) + (let* ([rest (substring line (string-length prefix) + (string-length line))] + [rest (if (and (> (string-length rest) 0) + (char=? #\return + (string-ref rest (- (string-length rest) 1)))) + (substring rest 0 (- (string-length rest) 1)) + rest)]) + (string->number rest))))) + + (define (read-message port) + (let ([len (read-header port)]) + (and len + (let ([buf (get-bytevector-n (standard-input-port) len)]) + (and (bytevector? buf) + (string->json-object (utf8->string buf))))))) + + (define (send-message port obj) + (let* ([body (json-object->string obj)] + [bv (string->utf8 body)] + [len (bytevector-length bv)]) + (display (string-append "Content-Length: " (number->string len) + "\r\n\r\n") port) + (put-bytevector (standard-output-port) bv) + (flush-output-port port) + (flush-output-port (standard-output-port)))) + + ;; ---- Response helpers ---- + + (define (lsp-respond port id result) + (let ([resp (make-hashtable string-hash string=?)]) + (hashtable-set! resp "jsonrpc" "2.0") + (hashtable-set! resp "id" id) + (hashtable-set! resp "result" result) + (send-message port resp))) + + (define (lsp-notify port method params) + (let ([msg (make-hashtable string-hash string=?)]) + (hashtable-set! msg "jsonrpc" "2.0") + (hashtable-set! msg "method" method) + (hashtable-set! msg "params" params) + (send-message port msg))) + + (define (lsp-respond-error port id code message) + (let ([resp (make-hashtable string-hash string=?)] + [err (make-hashtable string-hash string=?)]) + (hashtable-set! err "code" code) (hashtable-set! err "message" message) + (hashtable-set! resp "jsonrpc" "2.0") (hashtable-set! resp "id" id) + (hashtable-set! resp "error" err) + (send-message port resp))) + + (define (jref obj key . default) + (if (hashtable? obj) + (hashtable-ref obj key (if (null? default) #f (car default))) + (if (null? default) #f (car default)))) + + ;; ---- Method handlers ---- + + (define (make-json-obj . pairs) + (let ([ht (make-hashtable string-hash string=?)]) + (let loop ([p pairs]) + (unless (null? p) + (hashtable-set! ht (car p) (cadr p)) + (loop (cddr p)))) + ht)) + + (define (handle-initialize state params) + (lsp-state-root-path-set! state (jref params "rootPath")) + (make-json-obj + "capabilities" + (make-json-obj + "textDocumentSync" (make-json-obj "openClose" #t "change" 1) + "completionProvider" (make-json-obj "triggerCharacters" '("(" " " "-")) + "hoverProvider" #t) + "serverInfo" (make-json-obj "name" "jerboa-lsp" "version" "0.1.0"))) + + (define (handle-did-open state params) + (let* ([td (jref params "textDocument")] + [uri (jref td "uri")] + [text (jref td "text")]) + (when (and uri text) + (hashtable-set! (lsp-state-files state) uri text))) + (void)) + + (define (handle-did-change state params) + (let* ([td (jref params "textDocument")] + [uri (jref td "uri")] + [changes (jref params "contentChanges")]) + (when (and uri (pair? changes)) + ;; Full sync: take the last change's text + (let ([text (jref (car (reverse changes)) "text")]) + (when text + (hashtable-set! (lsp-state-files state) uri text))))) + (void)) + + (define (handle-did-close state params) + (let* ([td (jref params "textDocument")] + [uri (jref td "uri")]) + (when uri + (hashtable-delete! (lsp-state-files state) uri))) + (void)) + + (define (handle-completion state params) + ;; Extract word under cursor from document text + (let* ([td (jref params "textDocument")] + [uri (jref td "uri")] + [pos (jref params "position")] + [line-num (jref pos "line" 0)] + [col (jref pos "character" 0)] + [text (hashtable-ref (lsp-state-files state) + (or uri "") #f)] + [prefix (if text (extract-word text line-num col) "")]) + (let ([matches (symbol-db-complete prefix)]) + (map (lambda (m) + (let ([item (make-hashtable string-hash string=?)]) + (hashtable-set! item "label" (car m)) + (hashtable-set! item "kind" 3) ;; Function + (hashtable-set! item "detail" (cadr m)) + (hashtable-set! item "documentation" (caddr m)) + item)) + matches)))) + + (define (handle-hover state params) + (let* ([td (jref params "textDocument")] + [uri (jref td "uri")] + [pos (jref params "position")] + [line-num (jref pos "line" 0)] + [col (jref pos "character" 0)] + [text (hashtable-ref (lsp-state-files state) + (or uri "") #f)] + [word (if text (extract-word text line-num col) "")]) + (let ([info (symbol-db-lookup word)]) + (if info + (let ([result (make-hashtable string-hash string=?)] + [contents (make-hashtable string-hash string=?)]) + (hashtable-set! contents "kind" "markdown") + (hashtable-set! contents "value" + (string-append "**" word "** — " + (car info) "\n\n" + (cdr info))) + (hashtable-set! result "contents" contents) + result) + ;; no info — return null + (void))))) + + ;; ---- Text helpers ---- + + (define (extract-word text line-num col) + ;; Get the symbol-like word ending at (line, col) in text. + (let* ([lines (string-split text #\newline)] + [line (if (< line-num (length lines)) + (list-ref lines line-num) + "")] + [c (min col (string-length line))]) + ;; Walk backwards from col to find start of word + (let loop ([i (- c 1)] [chars '()]) + (if (or (< i 0) + (let ([ch (string-ref line i)]) + (or (char-whitespace? ch) + (memv ch '(#\( #\) #\[ #\] #\{ #\} #\' #\` #\, #\;))))) + (list->string chars) + (loop (- i 1) (cons (string-ref line i) chars)))))) + + (define (string-split str ch) + (let ([len (string-length str)]) + (let loop ([i 0] [start 0] [result '()]) + (cond + [(= i len) + (reverse (cons (substring str start len) result))] + [(char=? (string-ref str i) ch) + (loop (+ i 1) (+ i 1) + (cons (substring str start i) result))] + [else + (loop (+ i 1) start result)])))) + + ;; ---- Main dispatch ---- + + (define (handle-request state method params) + (cond + [(string=? method "initialize") + (handle-initialize state params)] + [(string=? method "initialized") (void)] + [(string=? method "shutdown") + (lsp-state-shutdown?-set! state #t) + (void)] ;; return null + [(string=? method "textDocument/didOpen") + (handle-did-open state params) (void)] + [(string=? method "textDocument/didChange") + (handle-did-change state params) (void)] + [(string=? method "textDocument/didClose") + (handle-did-close state params) (void)] + [(string=? method "textDocument/completion") + (handle-completion state params)] + [(string=? method "textDocument/hover") + (handle-hover state params)] + [else #f])) + + ;; ---- Server loop ---- + + (define (start-lsp-server) + (let ([state (make-lsp-state)] + [in (current-input-port)] + [out (current-output-port)]) + (let loop () + (let ([msg (read-message in)]) + (when msg + (let ([method (jref msg "method")] + [id (jref msg "id")] + [params (jref msg "params" + (make-hashtable string-hash string=?))]) + (cond + ;; exit notification + [(and method (string=? method "exit")) + (exit (if (lsp-state-shutdown? state) 0 1))] + ;; request (has id) + [(and method id) + (let ([result (handle-request state method params)]) + (if result + (lsp-respond out id result) + ;; method not found + (lsp-respond-error out id -32601 + (string-append + "Method not found: " + method)))) + (loop)] + ;; notification (no id) + [method + (handle-request state method params) + (loop)] + ;; unknown message shape + [else (loop)]))))))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/lsp/symbols.sls @@ -0,0 +1,128 @@ +#!chezscheme +;;; :std/lsp/symbols -- Symbol database for LSP completion and hover +;;; +;;; Provides a hashtable of known Jerboa/std exports for use by the +;;; LSP server's completion and hover handlers. + +(library (std lsp symbols) + (export symbol-db-init! symbol-db-lookup symbol-db-complete + symbol-db-add-module!) + (import (chezscheme)) + + ;; symbol-name-string -> (module-name . description) + (define *symbol-db* (make-hashtable string-hash string=?)) + + (define (symbol-db-add! name module desc) + (hashtable-set! *symbol-db* name (cons module desc))) + + (define (symbol-db-add-module! module-name entries) + ;; entries: list of (name . description) + (for-each + (lambda (e) + (symbol-db-add! (car e) module-name (cdr e))) + entries)) + + (define (symbol-db-lookup name) + (let ([v (hashtable-ref *symbol-db* name #f)]) + v)) + + (define (symbol-db-complete prefix) + (let ([len (string-length prefix)] + [result '()]) + (let-values ([(keys vals) (hashtable-entries *symbol-db*)]) + (vector-for-each + (lambda (k v) + (when (and (>= (string-length k) len) + (string=? prefix (substring k 0 len))) + (set! result (cons (list k (car v) (cdr v)) result)))) + keys vals)) + result)) + + (define (symbol-db-init!) + (symbol-db-add-module! "(jerboa prelude)" + '(("def" . "Define a binding (Gerbil-style)") + ("def*" . "Define with multiple clauses") + ("defrule" . "Define a syntax rule") + ("defstruct" . "Define a struct type with fields") + ("defclass" . "Define a class type") + ("defmethod" . "Define a method implementation") + ("match" . "Pattern matching expression") + ("try" . "Try/catch exception handling") + ("catch" . "Catch clause for try") + ("finally" . "Finally clause for try") + ("while" . "While loop") + ("until" . "Until loop (inverse while)") + ("hash-ref" . "Get value from hash table (error if missing)") + ("hash-get" . "Get value from hash table (returns #f if missing)") + ("hash-put!" . "Set value in hash table") + ("hash-update!" . "Update hash table value with procedure") + ("hash-remove!" . "Remove key from hash table") + ("hash-key?" . "Check if key exists in hash table") + ("hash->list" . "Convert hash table to alist") + ("hash-keys" . "List of hash table keys") + ("hash-values" . "List of hash table values") + ("hash-for-each" . "Iterate over hash table entries") + ("hash-map" . "Map over hash table entries") + ("hash-fold" . "Fold over hash table entries") + ("make-hash-table" . "Create a new hash table (equal-based)") + ("make-hash-table-eq" . "Create a new hash table (eq-based)") + ("hash-merge" . "Merge two hash tables (functional)") + ("hash-merge!" . "Merge two hash tables (mutating)") + ("displayln" . "Display value followed by newline") + ("iota" . "Generate list of integers [0, n)") + ("format" . "Format string (like Common Lisp format)") + ("printf" . "Formatted print to stdout") + ("let-hash" . "Bind hash table values to variables") + ("~" . "Method call syntax: (~ method obj args ...)"))) + + (symbol-db-add-module! "(std text json)" + '(("read-json" . "Read JSON from port or stdin") + ("write-json" . "Write Scheme value as JSON to port") + ("string->json-object" . "Parse JSON string to Scheme value") + ("json-object->string" . "Convert Scheme value to JSON string"))) + + (symbol-db-add-module! "(std sort)" + '(("sort" . "Sort a list with comparator (non-destructive)") + ("sort!" . "Sort a list with comparator") + ("stable-sort" . "Stable sort (preserves equal-element order)") + ("stable-sort!" . "Stable sort (in-place)"))) + + (symbol-db-add-module! "(std iter)" + '(("for" . "Iterate: (for ((x (in-list xs))) body ...)") + ("for/collect" . "Iterate and collect results into a list") + ("for/fold" . "Iterate with accumulator") + ("for/or" . "Iterate, return first truthy result") + ("for/and" . "Iterate, return #f if any body is #f") + ("in-list" . "Iterator over list elements") + ("in-vector" . "Iterator over vector elements") + ("in-range" . "Iterator over integer range") + ("in-string" . "Iterator over string characters") + ("in-hash-keys" . "Iterator over hash table keys") + ("in-hash-values" . "Iterator over hash table values") + ("in-hash-pairs" . "Iterator over hash table (key . value) pairs") + ("in-naturals" . "Infinite iterator 0, 1, 2, ...") + ("in-indexed" . "Iterator with index: (i . element)"))) + + (symbol-db-add-module! "(std misc thread)" + '(("spawn" . "Spawn a new thread running thunk") + ("spawn/name" . "Spawn a named thread") + ("thread-sleep!" . "Sleep current thread for N seconds") + ("thread-yield!" . "Yield current thread") + ("current-thread" . "Return current thread object") + ("thread-join!" . "Wait for thread to complete, return result") + ("make-mutex" . "Create a new mutex") + ("with-lock" . "Execute body while holding mutex"))) + + (symbol-db-add-module! "(std test)" + '(("check" . "Assert: (check expr => expected)") + ("check-exn" . "Assert expression raises exception") + ("test-suite" . "Define a named test suite") + ("run-test-suite!" . "Run a test suite"))) + + (symbol-db-add-module! "(std sugar)" + '(("with-catch" . "Catch exceptions: (with-catch handler thunk)") + ("with-destroy" . "Execute body, call destroy on exit") + ("defsyntax" . "Define a syntax transformer") + ("chain" . "Thread value through functions")))) + + ) ;; end library --- a/lib/std/net/address.sls +++ b/lib/std/net/address.sls @@ -50,7 +50,7 @@ (unless port (error 'parse-address "invalid port" str)) (make-address host port)) - (make-address str 0)))])) + (make-address str 0)))])) ;; close if, let, else-bracket, cond, define (define (address->string addr) (let ([host (address-host addr)] new file mode 100644 --- /dev/null +++ b/lib/std/protobuf.sls @@ -0,0 +1,245 @@ +#!chezscheme +;;; (std protobuf) — Protocol Buffers wire format encoding/decoding +;;; +;;; Pure Scheme implementation of proto3 wire format. +;;; Wire types: 0=varint, 1=64-bit, 2=length-delimited, 5=32-bit. + +(library (std protobuf) + (export + ;; Wire format encoding + protobuf-encode protobuf-decode + ;; Field helpers + make-field field? field-number field-value field-type + ;; Type constructors for encoding + pb-varint pb-fixed64 pb-fixed32 + pb-bytes pb-string pb-bool + pb-int32 pb-int64 pb-uint32 pb-uint64 + pb-sint32 pb-sint64 + pb-float pb-double + pb-repeated pb-embedded + ;; Decoding helpers + protobuf->alist + alist->protobuf) + + (import (chezscheme)) + + ;; ========== Field record ========== + + (define-record-type (pb-field make-field field?) + (fields + (immutable number field-number) + (immutable type field-type) + (immutable value field-value)) + (protocol + (lambda (new) + (lambda (number type value) + (new number type value))))) + + ;; ========== Varint encoding (LEB128) ========== + + (define (encode-varint n) + ;; Encode unsigned integer as LEB128 bytes, return list of bytes. + (let loop ([n (if (< n 0) + (bitwise-and n #xFFFFFFFFFFFFFFFF) + n)] + [acc '()]) + (let ([lo (bitwise-and n #x7F)] + [hi (bitwise-arithmetic-shift-right n 7)]) + (if (zero? hi) + (reverse (cons lo acc)) + (loop hi (cons (bitwise-ior lo #x80) acc)))))) + + (define (decode-varint bv pos) + ;; Returns (values decoded-value new-pos). + (let loop ([shift 0] [result 0] [i pos]) + (when (>= i (bytevector-length bv)) + (error 'decode-varint "unexpected end of input")) + (let ([byte (bytevector-u8-ref bv i)]) + (let ([result (bitwise-ior result + (bitwise-arithmetic-shift-left + (bitwise-and byte #x7F) shift))]) + (if (zero? (bitwise-and byte #x80)) + (values result (+ i 1)) + (loop (+ shift 7) result (+ i 1))))))) + + ;; ========== ZigZag encoding for signed integers ========== + + (define (zigzag-encode n bits) + (bitwise-xor (bitwise-arithmetic-shift-left n 1) + (bitwise-arithmetic-shift-right n (- bits 1)))) + + (define (zigzag-decode n) + (bitwise-xor (bitwise-arithmetic-shift-right n 1) + (- (bitwise-and n 1)))) + + ;; ========== Fixed-width encoding ========== + + (define (encode-fixed32 n) + (let ([bv (make-bytevector 4)]) + (bytevector-u32-set! bv 0 (bitwise-and n #xFFFFFFFF) (endianness little)) + bv)) + + (define (encode-fixed64 n) + (let ([bv (make-bytevector 8)]) + (bytevector-u64-set! bv 0 (bitwise-and n #xFFFFFFFFFFFFFFFF) (endianness little)) + bv)) + + (define (encode-float val) + (let ([bv (make-bytevector 4)]) + (bytevector-ieee-single-set! bv 0 val (endianness little)) + bv)) + + (define (encode-double val) + (let ([bv (make-bytevector 8)]) + (bytevector-ieee-double-set! bv 0 val (endianness little)) + bv)) + + ;; ========== Field tag encoding ========== + + (define (wire-type-for type) + (case type + [(varint int32 int64 uint32 uint64 sint32 sint64 bool) 0] + [(fixed64 sfixed64 double) 1] + [(bytes string embedded packed) 2] + [(fixed32 sfixed32 float) 5] + [else (error 'wire-type-for "unknown field type" type)])) + + (define (encode-tag field-num wire-type) + (encode-varint (bitwise-ior (bitwise-arithmetic-shift-left field-num 3) + wire-type))) + + ;; ========== Encode a single field's value ========== + + (define (encode-field-value type value) + (case type + [(varint uint32 uint64) + (encode-varint value)] + [(int32) + (encode-varint (bitwise-and value #xFFFFFFFF))] + [(int64) + (encode-varint (bitwise-and value #xFFFFFFFFFFFFFFFF))] + [(sint32) + (encode-varint (zigzag-encode value 32))] + [(sint64) + (encode-varint (zigzag-encode value 64))] + [(bool) + (encode-varint (if value 1 0))] + [(fixed32 sfixed32) + (bytevector->u8-list (encode-fixed32 value))] + [(fixed64 sfixed64) + (bytevector->u8-list (encode-fixed64 value))] + [(float) + (bytevector->u8-list (encode-float value))] + [(double) + (bytevector->u8-list (encode-double value))] + [(string) + (let ([bv (string->utf8 value)]) + (append (encode-varint (bytevector-length bv)) + (bytevector->u8-list bv)))] + [(bytes) + (append (encode-varint (bytevector-length value)) + (bytevector->u8-list value))] + [(embedded) + ;; value is a list of fields; encode recursively + (let ([inner (protobuf-encode value)]) + (append (encode-varint (bytevector-length inner)) + (bytevector->u8-list inner)))] + [(packed) + ;; value is (type . values-list) + (let* ([inner-type (car value)] + [vals (cdr value)] + [bytes (apply append + (map (lambda (v) (encode-field-value inner-type v)) + vals))] + [inner-bv (u8-list->bytevector bytes)]) + (append (encode-varint (bytevector-length inner-bv)) + bytes))] + [else (error 'encode-field-value "unknown type" type)])) + + ;; ========== Top-level encoder ========== + + (define (protobuf-encode fields) + ;; fields: list of field records + (let ([bytes (apply append + (map (lambda (f) + (let ([wt (wire-type-for (field-type f))]) + (append (encode-tag (field-number f) wt) + (encode-field-value (field-type f) + (field-value f))))) + fields))]) + (u8-list->bytevector bytes))) + + ;; ========== Top-level decoder ========== + + (define (protobuf-decode bv) + ;; Returns list of (field-number wire-type value). + (let loop ([pos 0] [acc '()]) + (if (>= pos (bytevector-length bv)) + (reverse acc)