Add jerboa expand subcommand to emit pure Chez R6RS from a package
ober
c92d65f53f08d2a169f8b02029d9809cd7afbd5d
--- a/bin/jerboa +++ b/bin/jerboa @@ -50,6 +50,7 @@ Commands: uninstall <name> Uninstall a package by name update [name] Update one or all installed packages list List installed packages + expand <dir> [out] Expand a Jerboa package to pure Chez Scheme R6RS pkg <cmd> [args] jpkg package manager (see: jerboa pkg --help) version Print version info help Print this help message @@ -253,6 +254,15 @@ cmd_build() { exec make -C "$JERBOA_HOME" build } +cmd_expand() { + if [ $# -eq 0 ]; then + echo "Error: jerboa expand requires a package directory" >&2 + echo "Usage: jerboa expand <package-dir> [output-dir]" >&2 + exit 1 + fi + exec "$SCHEME" --libdirs "$LIBDIRS" --script "$JERBOA_HOME/tools/expand-package.ss" "$@" +} + cmd_install() { if [ $# -eq 0 ]; then echo "Error: jerboa install requires a GitHub path" >&2 @@ -659,6 +669,10 @@ case "${1:-}" in build) cmd_build ;; + expand) + shift + cmd_expand "$@" + ;; install) shift cmd_install "$@" new file mode 100644 --- /dev/null +++ b/tools/expand-package.ss @@ -0,0 +1,311 @@ +#!chezscheme +;;; expand-package.ss -- Expand a Jerboa package into a self-contained +;;; directory of pure Chez Scheme R6RS libraries. +;;; +;;; Usage: scheme --script expand-package.ss <package-dir> [output-dir] +;;; +;;; The output directory contains: +;;; lib/ -- all .sls files (package + transitive jerboa stdlib deps) +;;; README.md -- instructions for use with stock Chez Scheme + +(import (chezscheme)) + +(define (die msg . args) + (apply fprintf (current-error-port) (string-append "expand: " msg "\n") args) + (exit 1)) + +(define (string-starts-with? s prefix) + (and (>= (string-length s) (string-length prefix)) + (string=? (substring s 0 (string-length prefix)) prefix))) + +(define (string-ends-with? s suffix) + (let ([slen (string-length s)] [sfxlen (string-length suffix)]) + (and (>= slen sfxlen) + (string=? (substring s (- slen sfxlen) slen) suffix)))) + +(define (ensure-dir path) + (unless (file-directory? path) + (mkdir path))) + +(define (ensure-dir-recursive path) + (let ([parts (string-split-char path #\/)]) + (let loop ([acc ""] [parts parts]) + (unless (null? parts) + (let ([next (string-append acc "/" (car parts))]) + (ensure-dir next) + (loop next (cdr parts))))))) + +(define (string-split-char str ch) + (let ([len (string-length str)]) + (let loop ([i 0] [start 0] [acc '()]) + (cond + [(>= i len) + (reverse (cons (substring str start len) acc))] + [(char=? (string-ref str i) ch) + (loop (+ i 1) (+ i 1) (cons (substring str start i) acc))] + [else + (loop (+ i 1) start acc)])))) + +(define (copy-file* src dst) + (when (file-exists? dst) (delete-file dst)) + (call-with-port (open-file-input-port src) + (lambda (in) + (call-with-port (open-file-output-port dst) + (lambda (out) + (let loop () + (let ([bv (get-bytevector-n in 65536)]) + (unless (eof-object? bv) + (put-bytevector out bv) + (loop))))))))) + +(define (find-ss-files dir) + (let loop ([dirs (list dir)] [result '()]) + (if (null? dirs) + (reverse result) + (let* ([current (car dirs)] + [rest (cdr dirs)] + [entries (guard (exn [#t '()]) (directory-list current))]) + (let inner ([entries entries] [subdirs rest] [files result]) + (if (null? entries) + (loop subdirs files) + (let* ([entry (car entries)] + [full (string-append current "/" entry)]) + (cond + [(char=? (string-ref entry 0) #\.) (inner (cdr entries) subdirs files)] + [(file-directory? full) (inner (cdr entries) (cons full subdirs) files)] + [(and (file-regular? full) (string-ends-with? entry ".ss")) + (inner (cdr entries) subdirs (cons full files))] + [else (inner (cdr entries) subdirs files)])))))))) + +(define (find-sls-files dir) + (let loop ([dirs (list dir)] [result '()]) + (if (null? dirs) + (reverse result) + (let* ([current (car dirs)] + [rest (cdr dirs)] + [entries (guard (exn [#t '()]) (directory-list current))]) + (let inner ([entries entries] [subdirs rest] [files result]) + (if (null? entries) + (loop subdirs files) + (let* ([entry (car entries)] + [full (string-append current "/" entry)]) + (cond + [(char=? (string-ref entry 0) #\.) (inner (cdr entries) subdirs files)] + [(file-directory? full) (inner (cdr entries) (cons full subdirs) files)] + [(and (file-regular? full) (string-ends-with? entry ".sls")) + (inner (cdr entries) subdirs (cons full files))] + [else (inner (cdr entries) subdirs files)])))))))) + +(define (file-contains-library-form? path) + (guard (exn [#t #f]) + (call-with-input-file path + (lambda (port) + (let loop () + (let ([form (get-datum port)]) + (cond + [(eof-object? form) #f] + [(and (pair? form) (eq? (car form) 'library)) #t] + [else (loop)]))))))) + +(define (extract-imports-from-file path) + (guard (exn [#t '()]) + (call-with-input-file path + (lambda (port) + (let loop ([imports '()]) + (let ([form (get-datum port)]) + (cond + [(eof-object? form) (reverse imports)] + [(and (pair? form) (eq? (car form) 'library)) + (extract-imports-from-library-form form)] + [(and (pair? form) (eq? (car form) 'import)) + (loop (append (cdr form) imports))] + [else (loop imports)]))))))) + +(define (extract-imports-from-library-form form) + (let loop ([parts (cdr form)] [imports '()]) + (cond + [(null? parts) (reverse imports)] + [(and (pair? (car parts)) (eq? (caar parts) 'import)) + (append (reverse (cdar parts)) imports)] + [else (loop (cdr parts) imports)]))) + +(define (import-spec->lib-ref spec) + (cond + [(and (pair? spec) (memq (car spec) '(except only prefix rename))) + (import-spec->lib-ref (cadr spec))] + [(and (pair? spec) (symbol? (car spec))) spec] + [else #f])) + +(define (jerboa-dep? lib-spec) + (let ([ref (import-spec->lib-ref lib-spec)]) + (and ref + (pair? ref) + (symbol? (car ref)) + (or (eq? (car ref) 'jerboa) + (eq? (car ref) 'std))))) + +(define (lib-spec->path lib-spec) + (string-join "/" (map symbol->string lib-spec))) + +(define (string-join sep strs) + (if (null? strs) + "" + (let loop ([acc (car strs)] [rest (cdr strs)]) + (if (null? rest) + acc + (loop (string-append acc sep (car rest)) (cdr rest)))))) + +(define (append-map f lst) + (apply append (map f lst))) + +(define (resolve-dep-file lib-spec jerboa-lib-dir) + (let ([base (lib-spec->path lib-spec)]) + (let ([sls (string-append jerboa-lib-dir "/" base ".sls")] + [ss (string-append jerboa-lib-dir "/" base ".ss")]) + (cond + [(file-exists? sls) sls] + [(file-exists? ss) ss] + [else #f])))) + +(define (collect-transitive-deps seed-imports jerboa-lib-dir) + (let ([visited (make-hashtable string-hash string=?)] + [result '()]) + (let loop ([queue seed-imports]) + (if (null? queue) + (reverse result) + (let* ([spec (car queue)] + [ref (import-spec->lib-ref spec)] + [key (if ref (lib-spec->path ref) "")]) + (if (or (not ref) + (not (jerboa-dep? spec)) + (hashtable-ref visited key #f)) + (loop (cdr queue)) + (begin + (hashtable-set! visited key #t) + (let ([src-file (resolve-dep-file ref jerboa-lib-dir)]) + (if src-file + (let ([new-imports (extract-imports-from-file src-file)]) + (set! result (cons (cons ref src-file) result)) + (loop (append (cdr queue) (filter jerboa-dep? new-imports)))) + (begin + (fprintf (current-error-port) + "expand: warning: cannot resolve dependency ~a\n" ref) + (loop (cdr queue)))))))))))) + +(define (copy-dep-to-output spec src-file output-lib-dir) + (let* ([rel (lib-spec->path spec)] + [dst-base (string-append output-lib-dir "/" rel)] + [dst-dir (let ([parts (string-split-char rel #\/)]) + (if (null? (cdr parts)) + output-lib-dir + (string-append output-lib-dir "/" + (string-join "/" (reverse (cdr (reverse parts)))))))] + [dst-file (string-append dst-base ".sls")]) + (ensure-dir-recursive dst-dir) + (copy-file* src-file dst-file))) + +(define (write-readme output-dir package-name) + (let ([readme-path (string-append output-dir "/README.md")]) + (call-with-output-file readme-path + (lambda (port) + (fprintf port "# ~a — Chez Scheme R6RS Distribution\n\n" package-name) + (fprintf port "This directory contains a self-contained distribution of **~a**\n" package-name) + (fprintf port "as pure R6RS libraries, usable with any standard Chez Scheme installation.\n\n") + (fprintf port "## Usage\n\n") + (fprintf port "Add the `lib/` subdirectory to your Chez Scheme library path:\n\n") + (fprintf port "```scheme\n") + (fprintf port "(library-directories (cons \"~a/lib\" (library-directories)))\n" package-name) + (fprintf port "```\n\n") + (fprintf port "Or from the command line:\n\n") + (fprintf port "```bash\n") + (fprintf port "scheme --libdirs ~a/lib your-program.ss\n" package-name) + (fprintf port "```\n\n") + (fprintf port "## Contents\n\n") + (fprintf port "- `lib/` — R6RS `.sls` library files (package sources + Jerboa stdlib dependencies)\n\n") + (fprintf port "## Requirements\n\n") + (fprintf port "- [Chez Scheme](https://cisco.github.io/ChezScheme/) 9.5+\n\n") + (fprintf port "---\n") + (fprintf port "Generated by `jerboa expand` from the [Jerboa](https://github.com/user/jerboa) toolchain.\n"))))) + +(define (main) + (let ([args (command-line-arguments)]) + (when (null? args) + (die "usage: jerboa expand <package-dir> [output-dir]")) + (let* ([package-dir (let ([d (car args)]) + (if (string-ends-with? d "/") + (substring d 0 (- (string-length d) 1)) + d))] + [package-name (let ([parts (string-split-char package-dir #\/)]) + (if (null? parts) package-dir (car (reverse parts))))] + [output-dir (if (>= (length args) 2) + (cadr args) + (string-append package-dir "-r6rs"))]) + + (unless (file-directory? package-dir) + (die "package directory not found: ~a" package-dir)) + + (let ([src-dir (string-append package-dir "/src")]) + (unless (file-directory? src-dir) + (die "no src/ directory in ~a" package-dir)) + + (printf "expand: ~a → ~a\n" package-dir output-dir) + + (when (file-directory? output-dir) + (die "output directory already exists: ~a (remove it first)" output-dir)) + + (let ([output-lib-dir (string-append output-dir "/lib")]) + (ensure-dir-recursive output-lib-dir) + + (let* ([ss-files (find-ss-files src-dir)] + [has-library-forms (and (pair? ss-files) + (file-contains-library-form? (car ss-files)))]) + + (if has-library-forms + (begin + (printf "expand: copying R6RS library files (~a files)\n" (length ss-files)) + (for-each + (lambda (ss-path) + (let* ([rel (substring ss-path (string-length src-dir) + (string-length ss-path))] + [dst (string-append output-lib-dir rel)]) + (ensure-dir-recursive + (let ([parts (string-split-char dst #\/)]) + (string-join "/" (reverse (cdr (reverse parts)))))) + (copy-file* ss-path dst))) + ss-files)) + (begin + (printf "expand: transpiling Jerboa sources (~a files)\n" (length ss-files)) + (let ([jerboa-home (or (getenv "JERBOA_HOME") + (die "JERBOA_HOME not set"))] + [scheme (or (getenv "SCHEME") + (string-append (or (getenv "JERBOA_HOME") ".") + "/.chez/bin/scheme"))]) + (let ([cmd (format "~a --libdirs ~a/lib --script ~a/jerbuild.ss transpile ~a ~a" + scheme jerboa-home jerboa-home src-dir output-lib-dir)]) + (let ([status (system cmd)]) + (unless (zero? status) + (die "jerbuild transpile failed (exit ~a)" status)))))))) + + (printf "expand: resolving Jerboa stdlib dependencies...\n") + (let* ([jerboa-home (or (getenv "JERBOA_HOME") + (die "JERBOA_HOME not set"))] + [jerboa-lib-dir (string-append jerboa-home "/lib")] + [output-files (find-sls-files output-lib-dir)] + [output-ss-files (find-ss-files output-lib-dir)] + [all-output-files (append output-files output-ss-files)] + [all-imports (append-map extract-imports-from-file all-output-files)] + [deps (collect-transitive-deps all-imports jerboa-lib-dir)]) + + (printf "expand: copying ~a stdlib dependencies\n" (length deps)) + (for-each + (lambda (dep) + (copy-dep-to-output (car dep) (cdr dep) output-lib-dir)) + deps) + + (write-readme output-dir package-name) + + (let ([total-files (length (find-sls-files output-lib-dir))]) + (printf "expand: done — ~a libraries in ~a/lib\n" + total-files output-dir)))))))) + +(main)