Phase 3c complete: Build & Package Tooling (5 libraries, 119 tests passing)
ober
322159d40b6df779298908e51401ccbaa4570889
new file mode 100644 --- /dev/null +++ b/lib/jerboa/cross.sls @@ -0,0 +1,159 @@ +#!chezscheme +;;; (jerboa cross) — Cross-Compilation Utilities +;;; +;;; Target OS/arch config, ABI info, and C compiler flag generation. + +(library (jerboa cross) + (export + make-cross-config cross-config? + cross-config-target-os cross-config-target-arch + cross-config-sysroot cross-config-cc cross-config-cflags + target-os-linux? target-os-macos? target-os-windows? + target-arch-x86-64? target-arch-aarch64? target-arch-riscv64? + detect-host-config cross-config-valid? + cc-flags-for-target abi-name endianness-for-target + pointer-size-for-target platform-string normalize-path-sep) + + (import (chezscheme)) + + ;; ========== String search helper ========== + (define (string-has-substring? str sub) + ;; Returns #t if sub appears anywhere in str. + (let ([slen (string-length str)] + [sublen (string-length sub)]) + (if (> sublen slen) + #f + (let loop ([i 0]) + (cond + [(> (+ i sublen) slen) #f] + [(let check ([j 0]) + (cond + [(= j sublen) #t] + [(char=? (string-ref str (+ i j)) (string-ref sub j)) + (check (+ j 1))] + [else #f])) + #t] + [else (loop (+ i 1))]))))) + + ;; ========== Cross Config ========== + + (define-record-type (%cross-config make-cross-config cross-config?) + (fields (immutable target-os cross-config-target-os) ;; symbol: linux macos windows + (immutable target-arch cross-config-target-arch) ;; symbol: x86-64 aarch64 riscv64 + (immutable sysroot cross-config-sysroot) ;; string path or #f + (immutable cc cross-config-cc) ;; string path to C compiler + (immutable cflags cross-config-cflags))) ;; list of strings + + ;; ========== Predicates ========== + + (define (target-os-linux? cfg) (eq? (cross-config-target-os cfg) 'linux)) + (define (target-os-macos? cfg) (eq? (cross-config-target-os cfg) 'macos)) + (define (target-os-windows? cfg) (eq? (cross-config-target-os cfg) 'windows)) + + (define (target-arch-x86-64? cfg) (eq? (cross-config-target-arch cfg) 'x86-64)) + (define (target-arch-aarch64? cfg) (eq? (cross-config-target-arch cfg) 'aarch64)) + (define (target-arch-riscv64? cfg) (eq? (cross-config-target-arch cfg) 'riscv64)) + + ;; ========== Host Detection ========== + + (define (machine-type->os mt) + ;; Detect OS from Chez machine-type symbol. + ;; e.g., a6le = x86-64 linux, ta6osx = x86-64 macos threaded + (let ([s (symbol->string mt)]) + (cond + [(or (string-has-substring? s "le") + (string-has-substring? s "l3")) 'linux] + [(or (string-has-substring? s "osx") + (string-has-substring? s "darwin")) 'macos] + [(or (string-has-substring? s "nt") + (string-has-substring? s "win")) 'windows] + [else 'linux]))) ;; default + + (define (machine-type->arch mt) + ;; Detect arch from Chez machine-type symbol. + ;; a6 = x86-64, arm64 = aarch64, rv = riscv64 + (let ([s (symbol->string mt)]) + (cond + [(string-has-substring? s "arm64") 'aarch64] + [(string-has-substring? s "arm") 'aarch64] + [(string-has-substring? s "a6") 'x86-64] + [(string-has-substring? s "rv") 'riscv64] + [(string-has-substring? s "i3") 'x86-64] ;; treat i386 as x86-64 for simplicity + [else 'x86-64]))) ;; default + + (define (detect-host-config) + ;; Return a cross-config for the current host. + (let* ([mt (machine-type)] + [os (machine-type->os mt)] + [arch (machine-type->arch mt)]) + (make-cross-config os arch #f "cc" '()))) + + ;; ========== Validation ========== + + (define (cross-config-valid? cfg) + ;; Check that OS and arch are known values. + (and (member (cross-config-target-os cfg) '(linux macos windows)) + (member (cross-config-target-arch cfg) '(x86-64 aarch64 riscv64)) + #t)) + + ;; ========== Compiler Flags ========== + + (define (cc-flags-for-target cfg) + ;; Generate GCC/Clang cross-compilation flags. + (let ([os (cross-config-target-os cfg)] + [arch (cross-config-target-arch cfg)] + [sr (cross-config-sysroot cfg)] + [extra (cross-config-cflags cfg)]) + (let* ([triple (abi-name cfg)] + [base (list (string-append "--target=" triple))]) + (append + base + (if sr (list (string-append "--sysroot=" sr)) '()) + extra)))) + + ;; ========== ABI / Platform Info ========== + + (define (abi-name cfg) + ;; Returns GNU/LLVM target triple string. + (let ([os (cross-config-target-os cfg)] + [arch (cross-config-target-arch cfg)]) + (let ([arch-str (case arch + [(x86-64) "x86_64"] + [(aarch64) "aarch64"] + [(riscv64) "riscv64"] + [else (symbol->string arch)])] + [os-str (case os + [(linux) "linux-gnu"] + [(macos) "apple-darwin"] + [(windows) "w64-mingw32"] + [else (symbol->string os)])]) + (string-append arch-str "-" os-str)))) + + (define (endianness-for-target cfg) + ;; Returns 'little or 'big. + ;; All currently supported arches are little-endian. + (case (cross-config-target-arch cfg) + [(x86-64 aarch64 riscv64) 'little] + [else 'little])) + + (define (pointer-size-for-target cfg) + ;; Returns 4 or 8. + (case (cross-config-target-arch cfg) + [(x86-64 aarch64 riscv64) 8] + [else 8])) + + (define (platform-string cfg) + ;; Human-readable platform description. + (let ([os (cross-config-target-os cfg)] + [arch (cross-config-target-arch cfg)]) + (format "~a/~a" arch os))) + + (define (normalize-path-sep path cfg) + ;; Convert / to \\ on Windows targets. + (if (target-os-windows? cfg) + (list->string + (map (lambda (c) (if (char=? c #\/) #\\ c)) + (string->list path))) + path)) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa/embed.sls @@ -0,0 +1,130 @@ +#!chezscheme +;;; (jerboa embed) — Embeddable Runtime / Sandbox API +;;; +;;; Isolated evaluation environments using Chez Scheme's environment system. + +(library (jerboa embed) + (export + make-sandbox sandbox? sandbox-eval sandbox-eval-string + sandbox-define! sandbox-ref sandbox-call sandbox-environment + sandbox-error? sandbox-error-message sandbox-error-irritants + sandbox-reset! sandbox-import! + make-sandbox-config sandbox-config? + with-sandbox) + + (import (chezscheme)) + + ;; ========== Sandbox Config ========== + + (define-record-type (%sandbox-config make-sandbox-config sandbox-config?) + (fields (immutable max-eval-time sandbox-config-max-eval-time) ;; ms or #f + (immutable allowed-imports sandbox-config-allowed-imports) ;; list or #f (all) + (immutable capture-output sandbox-config-capture-output))) ;; #t/#f + + ;; ========== Sandbox Error ========== + + (define-record-type (%sandbox-error make-sandbox-error sandbox-error?) + (fields (immutable message sandbox-error-message) + (immutable irritants sandbox-error-irritants))) + + ;; When error is called as (error "msg" irritants...) inside eval, + ;; Chez may set the message to an internal format string and put + ;; the actual message in the irritants list. + ;; Pattern: msg = "invalid message argument ~s (who = ~s, irritants = ~s)" + ;; irritants = (first-irritant "msg" (rest-irritants...)) + (define (exn->sandbox-error exn) + (cond + [(message-condition? exn) + (let ([msg (condition-message exn)] + [irrs (if (irritants-condition? exn) (condition-irritants exn) '())]) + ;; Detect the "invalid message argument" pattern from eval context + (if (and (string? msg) + (>= (string-length msg) 24) + (string=? (substring msg 0 24) "invalid message argument")) + ;; irritants = (first-arg "real-msg" (rest-args...)) + ;; Extract real message and irritants from the encoded form + (if (and (>= (length irrs) 3) + (string? (list-ref irrs 1))) + (make-sandbox-error + (list-ref irrs 1) + (let ([rest (list-ref irrs 2)]) + (if (list? rest) (cons (car irrs) rest) + (list (car irrs))))) + (make-sandbox-error msg irrs)) + (make-sandbox-error msg irrs)))] + [(string? exn) + (make-sandbox-error exn '())] + [else + (make-sandbox-error (format "~a" exn) '())])) + + ;; ========== Sandbox ========== + + ;; env: Chez environment (interaction-environment copy) + ;; config: sandbox-config or #f + ;; user-bindings: hashtable of name -> value (user definitions) + + (define-record-type (%sandbox make-sandbox-raw sandbox?) + (fields (mutable env sandbox-environment sandbox-environment-set!) + (mutable user-bindings sandbox-user-bindings sandbox-user-bindings-set!) + (immutable config sandbox-config-field))) + + (define (make-sandbox . args) + ;; Optional config as first arg. + (let ([config (if (and (pair? args) (sandbox-config? (car args))) + (car args) + #f)]) + (make-sandbox-raw + (copy-environment (interaction-environment) #t) + (make-hashtable equal-hash equal?) + config))) + + (define (sandbox-eval sb datum) + ;; Evaluate a datum in the sandbox. Returns result or sandbox-error. + (guard (exn [#t (exn->sandbox-error exn)]) + (eval datum (sandbox-environment sb)))) + + (define (sandbox-eval-string sb str) + ;; Read and eval a string in the sandbox. + (guard (exn [#t (exn->sandbox-error exn)]) + (let ([port (open-input-string str)]) + (let loop ([last (if #f #f)]) + (let ([form (read port)]) + (if (eof-object? form) + last + (loop (eval form (sandbox-environment sb))))))))) + + (define (sandbox-define! sb name val) + ;; Bind name (symbol) to val in the sandbox. + (hashtable-set! (sandbox-user-bindings sb) name val) + (eval `(define ,name ',val) (sandbox-environment sb))) + + (define (sandbox-ref sb name) + ;; Look up a binding in the sandbox. Returns value or raises error. + (guard (exn [#t (error 'sandbox-ref "unbound variable" name)]) + (eval name (sandbox-environment sb)))) + + (define (sandbox-call sb name . args) + ;; Call a procedure defined in the sandbox. + (guard (exn [#t (exn->sandbox-error exn)]) + (let ([proc (eval name (sandbox-environment sb))]) + (apply proc args)))) + + (define (sandbox-reset! sb) + ;; Clear user-defined bindings by creating a fresh environment. + (hashtable-clear! (sandbox-user-bindings sb)) + (sandbox-environment-set! sb + (copy-environment (interaction-environment) #t))) + + (define (sandbox-import! sb lib-name) + ;; Import a library into the sandbox. + ;; lib-name: e.g., '(std log) or '(chezscheme) + (guard (exn [#t (exn->sandbox-error exn)]) + (eval `(import ,lib-name) (sandbox-environment sb)))) + + (define-syntax with-sandbox + (syntax-rules () + [(_ sb body ...) + (let ([sb (make-sandbox)]) + body ...)])) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa/hot.sls @@ -0,0 +1,120 @@ +#!chezscheme +;;; (jerboa hot) — Hot Code Reload +;;; +;;; Watch files for modification using mtime polling and reload them. + +(library (jerboa hot) + (export + make-reloader reloader? reloader-watch! reloader-unwatch! + reloader-check! reloader-reload! reloader-watched + file-modified? file-mtimes + with-reloader reloader-on-reload! reloader-on-error! + reload-result? reload-result-file reload-result-success? reload-result-error + ;; Testing helper: mark a watched file as stale (mtime=unknown) + reloader-force-stale!) + + (import (chezscheme)) + + ;; ========== Reload Result ========== + + (define-record-type (%reload-result make-reload-result reload-result?) + (fields (immutable file reload-result-file) + (immutable success reload-result-success?) + (immutable error reload-result-error))) ;; #f or condition + + ;; ========== Reloader ========== + + ;; mtimes: hashtable path -> mtime (integer seconds) + ;; on-reload: procedure called with (path) on success; or #f + ;; on-error: procedure called with (path exn) on error; or #f + + (define-record-type (%reloader make-reloader-raw reloader?) + (fields (mutable mtimes reloader-mtimes reloader-mtimes-set!) + (mutable on-reload reloader-on-reload-cb reloader-on-reload-cb-set!) + (mutable on-error reloader-on-error-cb reloader-on-error-cb-set!))) + + (define (make-reloader) + (make-reloader-raw (make-hashtable equal-hash equal?) #f #f)) + + (define (reloader-on-reload! r cb) + (reloader-on-reload-cb-set! r cb)) + + (define (reloader-on-error! r cb) + (reloader-on-error-cb-set! r cb)) + + (define (get-mtime path) + (guard (exn [#t #f]) + (if (file-exists? path) + (file-modification-time path) + #f))) + + (define (mtime-equal? t1 t2) + (cond + [(and (not t1) (not t2)) #t] + [(or (not t1) (not t2)) #f] + [else (time=? t1 t2)])) + + (define (reloader-watch! r path) + ;; Add path to watch list, storing current mtime. + (let ([mtime (get-mtime path)]) + (hashtable-set! (reloader-mtimes r) path mtime))) + + (define (reloader-unwatch! r path) + (hashtable-delete! (reloader-mtimes r) path)) + + (define (reloader-watched r) + ;; Returns list of watched file paths. + (let-values ([(keys _) (hashtable-entries (reloader-mtimes r))]) + (vector->list keys))) + + (define (file-modified? r path) + ;; Returns #t if mtime differs from stored mtime. + (let ([stored (hashtable-ref (reloader-mtimes r) path #f)] + [current (get-mtime path)]) + (not (mtime-equal? stored current)))) + + (define (file-mtimes r) + ;; Returns alist of (path . mtime) for all watched files. + (let-values ([(keys vals) (hashtable-entries (reloader-mtimes r))]) + (let loop ([i 0] [acc '()]) + (if (= i (vector-length keys)) + acc + (loop (+ i 1) + (cons (cons (vector-ref keys i) (vector-ref vals i)) + acc)))))) + + (define (reloader-force-stale! r path) + ;; Mark a watched file as stale (for testing). Sets stored mtime to #f. + (hashtable-set! (reloader-mtimes r) path #f)) + + (define (reloader-check! r) + ;; Check all watched files; return list of changed file paths. + (filter (lambda (path) (file-modified? r path)) + (reloader-watched r))) + + (define (reloader-reload! r) + ;; For each changed file, reload it; return list of reload-results. + (let ([changed (reloader-check! r)]) + (map (lambda (path) + (let ([result + (guard (exn [#t (make-reload-result path #f exn)]) + (load path) + ;; Update stored mtime on success + (hashtable-set! (reloader-mtimes r) path (get-mtime path)) + (make-reload-result path #t #f))]) + ;; Fire callbacks + (if (reload-result-success? result) + (let ([cb (reloader-on-reload-cb r)]) + (when cb (cb path))) + (let ([cb (reloader-on-error-cb r)]) + (when cb (cb path (reload-result-error result))))) + result)) + changed))) + + (define-syntax with-reloader + (syntax-rules () + [(_ r body ...) + (let ([r (make-reloader)]) + body ...)])) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/jerboa/lock.sls @@ -0,0 +1,138 @@ +#!chezscheme +;;; (jerboa lock) — Lockfile Management +;;; +;;; S-expression lockfile for exact package pinning. + +(library (jerboa lock) + (export + ;; Lockfile + make-lockfile lockfile? lockfile-entries + lockfile-add! lockfile-remove! lockfile-lookup lockfile-has? + + ;; Lock entry + make-lock-entry lock-entry? lock-entry-name lock-entry-version + lock-entry-hash lock-entry-deps + + ;; Serialization + lockfile->sexp sexp->lockfile lockfile-write lockfile-read + + ;; Operations + lockfile-merge lockfile-diff) + + (import (chezscheme)) + + ;; ========== Lock Entry ========== + + (define-record-type (%lock-entry make-lock-entry lock-entry?) + (fields (immutable name lock-entry-name) ;; string + (immutable version lock-entry-version) ;; string "1.2.3" + (immutable hash lock-entry-hash) ;; string SHA-256 hex + (immutable deps lock-entry-deps))) ;; list of strings (names) + + ;; ========== Lockfile ========== + + (define-record-type (%lockfile make-lockfile lockfile?) + (fields (mutable entries lockfile-entries lockfile-entries-set!))) ;; list of lock-entry + + (define (lockfile-add! lf entry) + ;; Add or replace an entry by name. + (let ([existing (filter (lambda (e) + (not (equal? (lock-entry-name e) + (lock-entry-name entry)))) + (lockfile-entries lf))]) + (lockfile-entries-set! lf (cons entry existing)))) + + (define (lockfile-remove! lf name) + (lockfile-entries-set! lf + (filter (lambda (e) (not (equal? (lock-entry-name e) name))) + (lockfile-entries lf)))) + + (define (lockfile-lookup lf name) + ;; Returns lock-entry or #f. + (let loop ([es (lockfile-entries lf)]) + (cond + [(null? es) #f] + [(equal? (lock-entry-name (car es)) name) (car es)] + [else (loop (cdr es))]))) + + (define (lockfile-has? lf name) + (if (lockfile-lookup lf name) #t #f)) + + ;; ========== Serialization ========== + + (define (lockfile->sexp lf) + ;; Returns: (lockfile (entry name ver hash (dep ...)) ...) + `(lockfile + ,@(map (lambda (e) + `(entry ,(lock-entry-name e) + ,(lock-entry-version e) + ,(lock-entry-hash e) + ,(lock-entry-deps e))) + (lockfile-entries lf)))) + + (define (sexp->lockfile sexp) + ;; Parse: (lockfile (entry name ver hash (deps ...)) ...) + (unless (and (pair? sexp) (eq? (car sexp) 'lockfile)) + (error 'sexp->lockfile "invalid lockfile sexp" sexp)) + (let ([entries + (map (lambda (form) + (unless (and (pair? form) + (eq? (car form) 'entry) + (>= (length form) 5)) + (error 'sexp->lockfile "invalid entry form" form)) + (make-lock-entry + (list-ref form 1) + (list-ref form 2) + (list-ref form 3) + (list-ref form 4))) + (cdr sexp))]) + (make-lockfile entries))) + + (define (lockfile-write lf port) + ;; Write lockfile as S-expression to port. + (write (lockfile->sexp lf) port) + (newline port)) + + (define (lockfile-read port) + ;; Read a lockfile from port. + (let ([sexp (read port)]) + (if (eof-object? sexp) + (make-lockfile '()) + (sexp->lockfile sexp)))) + + ;; ========== Merge and Diff ========== + + (define (lockfile-merge lf1 lf2) + ;; Merge lf1 and lf2; lf2 entries take precedence on conflicts. + (let ([result (make-lockfile '())]) + ;; Add all lf1 entries first + (for-each (lambda (e) (lockfile-add! result e)) + (lockfile-entries lf1)) + ;; Add all lf2 entries (overrides lf1 on same name) + (for-each (lambda (e) (lockfile-add! result e)) + (lockfile-entries lf2)) + result)) + + (define (lockfile-diff lf1 lf2) + ;; Returns (added removed changed): + ;; added = entries in lf2 not in lf1 (by name) + ;; removed = entries in lf1 not in lf2 (by name) + ;; changed = entries in both but with different version or hash + (let* ([e1 (lockfile-entries lf1)] + [e2 (lockfile-entries lf2)] + [names1 (map lock-entry-name e1)] + [names2 (map lock-entry-name e2)] + [added (filter (lambda (e) (not (member (lock-entry-name e) names1))) e2)] + [removed (filter (lambda (e) (not (member (lock-entry-name e) names2))) e1)] + [changed + (filter (lambda (e2-entry) + (let ([e1-entry (lockfile-lookup lf1 (lock-entry-name e2-entry))]) + (and e1-entry + (not (and (equal? (lock-entry-version e1-entry) + (lock-entry-version e2-entry)) + (equal? (lock-entry-hash e1-entry) + (lock-entry-hash e2-entry))))))) + e2)]) + (list added removed changed))) + +) ;; end library --- a/lib/jerboa/pkg.sls +++ b/lib/jerboa/pkg.sls @@ -1,357 +1,191 @@ #!chezscheme -;;; (jerboa pkg) — Package Manager (Step 34) +;;; (jerboa pkg) — Package Manager ;;; -;;; Content-addressed package store with lock files. -;;; Supports source (git/local) and version-range dependencies. +;;; Semantic versioning, dependency resolution, manifests. (library (jerboa pkg) (export - ;; Package manifest - make-package - package? - package-name - package-version - package-dependencies - package-description + ;; Package records + make-package package? package-name package-version package-deps + package-description package-author - ;; Version handling - make-version - version? - version-major - version-minor - version-patch - version->string - string->version - version<? - version=? - version-satisfies? + ;; Version operations + version->list version-compare version<? version=? version>=? - ;; Dependency spec - make-dep-spec - dep-spec? - dep-spec-name - dep-spec-constraint - dep-spec-source + ;; Dependency records + make-dep dep? dep-name dep-version-constraint - ;; Package registry - make-registry - registry? - registry-add! - registry-find - registry-list + ;; Constraint checking + constraint-satisfied? ;; Resolution - resolve-dependencies - dependency-graph - topological-sort + resolve-deps dependency-order - ;; Lock file - make-lock-file - lock-file? - lock-file-write - lock-file-read - - ;; Package.sls reader - read-package-file - write-package-file) + ;; Manifest + make-manifest manifest? manifest-packages + manifest-add manifest-remove manifest-lookup) (import (chezscheme)) - ;; ========== Version ========== - - (define-record-type (version make-version version?) - (fields (immutable major version-major) - (immutable minor version-minor) - (immutable patch version-patch))) - - (define (version->string v) - (format "~a.~a.~a" - (version-major v) (version-minor v) (version-patch v))) - - (define (string->version s) - ;; Parse "major.minor.patch" — missing parts default to 0 - (let ([parts (let loop ([s s] [acc '()]) - (let ([idx (let scan ([i 0]) - (cond [(= i (string-length s)) #f] - [(char=? (string-ref s i) #\.) i] - [else (scan (+ i 1))]))]) - (if idx - (loop (substring s (+ idx 1) (string-length s)) - (cons (substring s 0 idx) acc)) - (reverse (cons s acc)))))]) - (let ([nums (map (lambda (p) - (guard (exn [#t 0]) (string->number p))) - parts)]) - (make-version - (if (>= (length nums) 1) (or (list-ref nums 0) 0) 0) - (if (>= (length nums) 2) (or (list-ref nums 1) 0) 0) - (if (>= (length nums) 3) (or (list-ref nums 2) 0) 0))))) + ;; ========== Package ========== - (define (version<? a b) - (or (< (version-major a) (version-major b)) - (and (= (version-major a) (version-major b)) - (or (< (version-minor a) (version-minor b)) - (and (= (version-minor a) (version-minor b)) - (< (version-patch a) (version-patch b))))))) + (define-record-type (%package make-package package?) + (fields (immutable name package-name) + (immutable version package-version) ;; string "1.2.3" + (immutable deps package-deps) ;; list of dep + (immutable description package-description) + (immutable author package-author))) - (define (version=? a b) - (and (= (version-major a) (version-major b)) - (= (version-minor a) (version-minor b)) - (= (version-patch a) (version-patch b)))) + ;; ========== Version ========== - (define (version-satisfies? v constraint) - ;; constraint: string like "^1.2.0", "~1.2", ">=1.0.0", "1.2.3", "*" + (define (version->list ver-str) + ;; "1.2.3" -> (1 2 3) + (let loop ([s ver-str] [acc '()]) + (let ([idx (let scan ([i 0]) + (cond [(= i (string-length s)) #f] + [(char=? (string-ref s i) #\.) i] + [else (scan (+ i 1))]))]) + (if idx + (loop (substring s (+ idx 1) (string-length s)) + (cons (string->number (substring s 0 idx)) acc)) + (reverse (cons (or (string->number s) 0) acc)))))) + + (define (version-compare a b) + ;; Compare version strings a and b. + ;; Returns -1, 0, or 1. + (let ([la (version->list a)] + [lb (version->list b)]) + (let loop ([la la] [lb lb]) + (cond + [(and (null? la) (null? lb)) 0] + [(null? la) -1] + [(null? lb) 1] + [(< (car la) (car lb)) -1] + [(> (car la) (car lb)) 1] + [else (loop (cdr la) (cdr lb))])))) + + (define (version<? a b) (= (version-compare a b) -1)) + (define (version=? a b) (= (version-compare a b) 0)) + (define (version>=? a b) (>= (version-compare a b) 0)) + + ;; ========== Dependency ========== + + (define-record-type (%dep make-dep dep?) + (fields (immutable name dep-name) + (immutable version-constraint dep-version-constraint))) + + ;; ========== Constraint Checking ========== + + (define (constraint-satisfied? ver-str constraint) + ;; constraint: "*", ">=1.0.0", "^1.0.0", "~1.2.0", "=1.0.0", "1.0.0" (cond [(equal? constraint "*") #t] + [(and (>= (string-length constraint) 2) + (string=? (substring constraint 0 2) ">=")) + (version>=? ver-str (substring constraint 2 (string-length constraint)))] [(and (>= (string-length constraint) 1) (char=? (string-ref constraint 0) #\^)) - ;; Caret: compatible with, major must match - (let ([base (string->version (substring constraint 1 (string-length constraint)))]) - (and (= (version-major v) (version-major base)) - (or (> (version-minor v) (version-minor base)) - (and (= (version-minor v) (version-minor base)) - (>= (version-patch v) (version-patch base))))))] + ;; Caret: same major, >= base minor.patch + (let* ([base (substring constraint 1 (string-length constraint))] + [blist (version->list base)] + [vlist (version->list ver-str)]) + (and (= (car vlist) (car blist)) + (or (> (cadr vlist) (cadr blist)) + (and (= (cadr vlist) (cadr blist)) + (>= (caddr vlist) (caddr blist))))))] [(and (>= (string-length constraint) 1) (char=? (string-ref constraint 0) #\~)) - ;; Tilde: compatible minor, patch can vary - (let ([base (string->version (substring constraint 1 (string-length constraint)))]) - (and (= (version-major v) (version-major base)) - (= (version-minor v) (version-minor base)) - (>= (version-patch v) (version-patch base))))] - [(and (>= (string-length constraint) 2) - (string=? (substring constraint 0 2) ">=")) - (let ([base (string->version (substring constraint 2 (string-length constraint)))]) - (or (version=? v base) (version<? base v)))] + ;; Tilde: same major.minor, >= base patch + (let* ([base (substring constraint 1 (string-length constraint))] + [blist (version->list base)] + [vlist (version->list ver-str)]) + (and (= (car vlist) (car blist)) + (= (cadr vlist) (cadr blist)) + (>= (caddr vlist) (caddr blist))))] [(and (>= (string-length constraint) 1) - (char=? (string-ref constraint 0) #\>)) - (let ([base (string->version (substring constraint 1 (string-length constraint)))]) - (version<? base v))] + (char=? (string-ref constraint 0) #\=)) + (version=? ver-str (substring constraint 1 (string-length constraint)))] [else - ;; Exact version match - (version=? v (string->version constraint))])) - - ;; ========== Dependency Spec ========== - - (define-record-type (dep-spec make-dep-spec dep-spec?) - (fields (immutable name dep-spec-name) - (immutable constraint dep-spec-constraint) ;; version constraint string - (immutable source dep-spec-source))) ;; #f | '(git url tag) | '(local path) - - ;; ========== Package ========== - - (define-record-type (package make-package package?) - (fields (immutable name package-name) - (immutable version package-version) ;; version record - (immutable dependencies package-dependencies) ;; list of dep-spec - (immutable description package-description) - (immutable authors package-authors) - (immutable license package-license))) - - ;; ========== Registry ========== - - ;; registry: hashtable mapping name → list of (version . package) - (define-record-type (registry make-registry-raw registry?) - (fields (immutable packages registry-packages) ;; hashtable: name → alist (ver . pkg) - (immutable mutex registry-mutex))) - - (define (make-registry) - (make-registry-raw (make-hashtable equal-hash equal?) (make-mutex))) - - (define (registry-add! reg pkg) - (with-mutex (registry-mutex reg) - (let* ([name (package-name pkg)] - [ver (package-version pkg)] - [existing (hashtable-ref (registry-packages reg) name '())]) - (hashtable-set! (registry-packages reg) name - (cons (cons ver pkg) - (filter (lambda (e) (not (version=? (car e) ver))) existing)))))) - - (define (registry-find reg name constraint) - ;; Find best (highest) version satisfying constraint. - ;; Returns package or #f. - (with-mutex (registry-mutex reg) - (let ([entries (hashtable-ref (registry-packages reg) name '())]) - (let ([satisfying - (filter (lambda (e) (version-satisfies? (car e) constraint)) - entries)]) - (if (null? satisfying) - #f - (let ([sorted (list-sort (lambda (a b) (version<? (car b) (car a))) - satisfying)]) - (cdar sorted))))))) - - (define (registry-list reg) - (with-mutex (registry-mutex reg) - (let-values ([(names _) (hashtable-entries (registry-packages reg))]) - (vector->list names)))) + ;; Exact match + (version=? ver-str constraint)])) ;; ========== Dependency Resolution ========== - (define (resolve-dependencies registry pkg visited) - ;; Resolve all transitive dependencies of pkg. - ;; Returns alist of (name . resolved-package) or raises error. - (let loop ([deps (package-dependencies pkg)] - [resolved '()] - [seen visited]) - (if (null? deps) - resolved - (let* ([dep (car deps)] - [name (dep-spec-name dep)] - [cstr (dep-spec-constraint dep)]) - (if (assoc name resolved) - ;; Already resolved - (loop (cdr deps) resolved seen) - (let ([pkg2 (registry-find registry name cstr)]) - (if (not pkg2) - (error 'resolve-dependencies - "package not found in registry" - name cstr) - ;; Recursively resolve pkg2's deps (avoid cycles via seen) - (if (member name seen) - (loop (cdr deps) resolved seen) ;; circular dep — skip - (let ([sub-resolved - (resolve-dependencies registry pkg2 (cons name seen))]) - (loop (cdr deps) - (cons (cons name pkg2) - (append sub-resolved resolved)) - (cons name seen))))))))))) - - (define (dependency-graph pkg registry) - ;; Returns alist: name → list of dependency names - (let ([resolved (resolve-dependencies registry pkg '())]) - (map (lambda (entry) - (cons (car entry) - (map dep-spec-name - (package-dependencies (cdr entry))))) - resolved))) - - (define (topological-sort graph) - ;; Kahn's algorithm for topological sort. - ;; graph: alist (node . list-of-deps) - ;; deps = what this node needs (prerequisites) - ;; Returns list of nodes in dependency order (deps first). - (let* ([nodes (map car graph)] - ;; in-degree = number of prerequisites each node has - [in-degree - (let ([ht (make-hashtable equal-hash equal?)]) - (for-each (lambda (n) - (hashtable-set! ht n - (length (filter (lambda (d) (member d nodes)) - (let ([e (assoc n graph)]) - (if e (cdr e) '())))))) - nodes) - ht)] - ;; reverse-graph: node -> list of nodes that depend on it - [rev - (let ([ht (make-hashtable equal-hash equal?)]) - (for-each (lambda (n) (hashtable-set! ht n '())) nodes) + (define (resolve-deps packages root-pkg) + ;; Given a list of packages and a root package, return packages + ;; in dependency order (topological sort, deps first). + ;; Raises error on circular deps or unsatisfied deps. + (let ([pkg-map (let ([ht (make-hashtable equal-hash equal?)]) + (for-each (lambda (p) + (hashtable-set! ht (package-name p) p)) + packages) + ht)]) + ;; Topological sort with cycle detection + (let ([visited (make-hashtable equal-hash equal?)] + [in-stack (make-hashtable equal-hash equal?)] + [result '()]) + (define (visit pkg) + (let ([name (package-name pkg)]) + (when (hashtable-ref in-stack name #f) + (error 'resolve-deps "circular dependency detected" name)) + (unless (hashtable-ref visited name #f) + (hashtable-set! in-stack name #t) (for-each - (lambda (entry) - (for-each - (lambda (dep) - (when (member dep nodes) - (hashtable-set! ht dep - (cons (car entry) (hashtable-ref ht dep '()))))) - (cdr entry))) - graph) - ht)] - [queue (filter (lambda (n) (= 0 (hashtable-ref in-degree n 0))) nodes)]) - (let loop ([q queue] [result '()]) - (if (null? q) - (if (= (length result) (length nodes)) - (reverse result) - (error 'topological-sort "cycle detected in dependencies")) - (let* ([n (car q)] - ;; nodes that depend on n (n is a prereq for them) - [dependents (hashtable-ref rev n '())] - [new-q - (let inner ([ds dependents] [q (cdr q)]) - (if (null? ds) q - (let* ([m (car ds)] - [deg (- (hashtable-ref in-degree m 1) 1)]) - (hashtable-set! in-degree m deg) - (inner (cdr ds) - (if (= deg 0) (cons m q) q)))))]) - (loop new-q (cons n result))))))) - - ;; ========== Lock File ========== - - (define-record-type (lock-file make-lock-file lock-file?) - (fields (immutable entries lock-entries))) ;; list of (name version source-hash) - - (define (lock-file-write lf port) - ;; Write lock file as S-expression - (for-each - (lambda (e) - (write e port) - (newline port)) - (lock-entries lf))) - - (define (lock-file-read port) - ;; Read lock file from S-expression - (let loop ([entry (read port)] [entries '()]) - (if (eof-object? entry) - (make-lock-file (reverse entries)) - (loop (read port) (cons entry entries))))) - - ;; ========== Package File Reader ========== - - (define (read-package-file path) - ;; Read a package manifest S-expression from file. - ;; Returns a package record. - (if (not (file-exists? path)) - (error 'read-package-file "file not found" path) - (call-with-input-file path - (lambda (port) - (let ([form (read port)]) - (parse-package-sexp form)))))) - - (define (parse-package-sexp form) - ;; Parse: (package (name "foo") (version "1.0.0") (dependencies ...) ...) - (if (not (and (pair? form) (eq? (car form) 'package))) - (error 'parse-package-sexp "invalid package form" form) - (let ([clauses (cdr form)]) - (let ([name (let ([c (assq 'name clauses)]) (and c (cadr c)))] - [ver-str (let ([c (assq 'version clauses)]) (and c (cadr c)))] - [deps (let ([c (assq 'dependencies clauses)]) (and c (cdr c)))] - [desc (let ([c (assq 'description clauses)]) (and c (cadr c)))] - [authors (let ([c (assq 'authors clauses)]) (and c (cdr c)))] - [license (let ([c (assq 'license clauses)]) (and c (cadr c)))]) - (unless name - (error 'parse-package-sexp "missing name in package")) - (make-package - name - (if ver-str (string->version ver-str) (make-version 0 0 0)) - (map parse-dep (or deps '())) - (or desc "") - (or authors '()) - (or license "")))))) - - (define (parse-dep dep-form) - ;; Parse: (name "^1.0.0") or (name "1.0.0" (git "url" #:tag "v1.0")) - (if (not (pair? dep-form)) - (error 'parse-dep "invalid dependency" dep-form) - (let ([name (car dep-form)] - [cstr (cadr dep-form)] - [src (if (>= (length dep-form) 3) (caddr dep-form) #f)]) - (make-dep-spec name cstr src)))) -