From 5380ac9307d6f735244bfef1d3a97391603acf6f Mon Sep 17 00:00:00 2001 From: Puck Meerburg Date: Mon, 25 Nov 2024 22:06:44 +0000 Subject: [PATCH] (zilch lang rust): initial commit --- core/src/semver.sld | 6 +- core/src/zexpr.sld | 2 +- lang/rust/buildrs-runner.rs | 10 + lang/rust/default.nix | 19 ++ lang/rust/src/build-script.sld | 133 +++++++++ lang/rust/src/cargo.sld | 362 ++++++++++++++++++++++++ lang/rust/src/cfg.sld | 124 +++++++++ lang/rust/src/registry.sld | 82 ++++++ lang/rust/src/resolver.sld | 493 +++++++++++++++++++++++++++++++++ lang/rust/src/rust.sld | 140 ++++++++++ lang/rust/zilch-lang-rust.egg | 22 ++ shell.nix | 2 + 12 files changed, 1392 insertions(+), 3 deletions(-) create mode 100644 lang/rust/buildrs-runner.rs create mode 100644 lang/rust/default.nix create mode 100644 lang/rust/src/build-script.sld create mode 100644 lang/rust/src/cargo.sld create mode 100644 lang/rust/src/cfg.sld create mode 100644 lang/rust/src/registry.sld create mode 100644 lang/rust/src/resolver.sld create mode 100644 lang/rust/src/rust.sld create mode 100644 lang/rust/zilch-lang-rust.egg diff --git a/core/src/semver.sld b/core/src/semver.sld index 3d4b2a3..d6ccfa7 100644 --- a/core/src/semver.sld +++ b/core/src/semver.sld @@ -4,7 +4,7 @@ (chicken base) (chicken format) (srfi 152)) (export - version-major version-minor version-patch version-prerelease version-build-metadata + make-version version-major version-minor version-patch version-prerelease version-build-metadata version-str parse-version version=? version runner_source.h + ''; +} diff --git a/lang/rust/src/build-script.sld b/lang/rust/src/build-script.sld new file mode 100644 index 0000000..3ad4a2f --- /dev/null +++ b/lang/rust/src/build-script.sld @@ -0,0 +1,133 @@ +(define-library (zilch lang rust build-script) + (import + (scheme base) (scheme write) (scheme process-context) (scheme lazy) + (zilch file) (zilch magic) (zilch nix drv) (zilch nix path) (scheme char) + (zilch nixpkgs) (zilch zexpr) (zilch semver) + json + (chicken process) + (chicken base) (chicken format) + (chicken foreign) + (srfi 4) (srfi 128) (srfi 146) (srfi 152) (srfi 207) + (zilch lang rust)) + + (export + + make-build-script-output build-script-output? + build-script-output-rerun-if-changed build-script-output-rerun-if-env-changed + build-script-output-link-arg build-script-output-link-lib build-script-output-link-search + build-script-output-flags build-script-output-cfg build-script-output-check-cfg + build-script-output-env build-script-output-warning build-script-output-metadata + + call-runner) + + (begin + (define-record-type + (make-build-script-output rerun-if-changed rerun-if-env-changed link-arg link-lib link-search flags cfg check-cfg env warning metadata) + build-script-output? + (rerun-if-changed build-script-output-rerun-if-changed set-build-script-output-rerun-if-changed!) + (rerun-if-env-changed build-script-output-rerun-if-env-changed set-build-script-output-rerun-if-env-changed!) + (link-arg build-script-output-link-arg set-build-script-output-link-arg!) + (link-lib build-script-output-link-lib set-build-script-output-link-lib!) + (link-search build-script-output-link-search set-build-script-output-link-search!) + (flags build-script-output-flags set-build-script-output-flags!) + (cfg build-script-output-cfg set-build-script-output-cfg!) + (check-cfg build-script-output-check-cfg set-build-script-output-check-cfg!) + (env build-script-output-env set-build-script-output-env!) + (warning build-script-output-warning set-build-script-output-warning!) + (metadata build-script-output-metadata set-build-script-output-metadata!)) + (define-record-printer ( entry out) + (fprintf out "#" + (build-script-output-rerun-if-changed entry) + (build-script-output-rerun-if-env-changed entry) + (build-script-output-flags entry) + (build-script-output-cfg entry) + (build-script-output-check-cfg entry) + (build-script-output-env entry))) + + (define linker (delay (let ((v (cdr (assoc "out" (nixpkgs "gcc"))))) #~,(string-append #$v "/bin/cc")))) + + (foreign-declare "#include \"runner_source.h\"") + (define runner-runner + (cdar + (call-rustc + (zfile (foreign-value "runner_source" nonnull-c-string)) '() + #:codegen-flags (cons "linker" (force linker)) + #:crate-type 'bin + #:crate-name "runner" + #:edition "2021" + #:emits '(#:link #t)))) + + (define (parse-build-script-line line out) + ;; Rewrite cargo:foo -> cargo::foo + (when (and (string-prefix? "cargo:" line) (not (string-prefix? "cargo::" line))) + (set! line (string-append "cargo::" (string-copy line 6)))) + (cond + ((string-prefix? "cargo::rerun-if-changed=" line) + (set-build-script-output-rerun-if-changed! out (cons (string-copy line 24) (build-script-output-rerun-if-changed out)))) + ((string-prefix? "cargo::rerun-if-env-changed=" line) + (set-build-script-output-rerun-if-env-changed! out (cons (string-copy line 28) (build-script-output-rerun-if-env-changed out)))) + ((string-prefix? "cargo::rustc-flags=" line) + (set-build-script-output-flags! out (cons (string-copy line 19) (build-script-output-flags out)))) + ((string-prefix? "cargo::rustc-cfg=" line) + (let* ((kv (string-copy line 17)) + (splat-start (and (string-suffix? "\"" kv) (string-contains kv "=\"")))) + (set-build-script-output-cfg! out + (cons + (if splat-start + (cons (string-copy kv 0 splat-start) (string-copy kv (+ splat-start 2) (- (string-length kv) 1))) + kv) + (build-script-output-cfg out))))) + ((string-prefix? "cargo::rustc-check-cfg=" line) + (set-build-script-output-check-cfg! out (cons (string-copy line 23) (build-script-output-check-cfg out)))) + ((string-prefix? "cargo::rustc-env=" line) + (let* ((kv (string-copy line 17)) + (splat-start (string-contains kv "="))) + (set-build-script-output-env! out + (cons + (cons (string-copy kv 0 splat-start) (string-copy kv (+ splat-start 1))) + (build-script-output-env out))))) + ((string-prefix? "cargo::metadata=" line) + (let* ((kv (string-copy line 16)) + (splat-start (string-contains kv "="))) + (set-build-script-output-metadata! out + (cons + (cons (string-copy kv 0 splat-start) (string-copy kv (+ splat-start 1))) + (build-script-output-metadata out))))) + ((string-prefix? "cargo::rustc-link-search=" line) + (let* ((kv (string-copy line 25)) + (splat-start (string-contains kv "="))) + (set-build-script-output-link-search! out + (cons + (if splat-start (cons (string-copy kv 0 splat-start) (string-copy kv (+ splat-start 1))) + kv) + (build-script-output-link-search out))))) + ((string-prefix? "cargo::rustc-link-lib=" line) + (set-build-script-output-link-lib! out + (cons + (string-copy line 22) + (build-script-output-link-lib out)))) + + ; TODO(puck): bad + ((string-prefix? "cargo::" line) + (let* ((kv (string-copy line 7)) + (splat-start (string-contains kv "="))) + (set-build-script-output-metadata! out + (cons + (cons (string-copy kv 0 splat-start) (string-copy kv (+ splat-start 1))) + (build-script-output-metadata out))))))) + ;; TODO: link-arg-*, warning, others? + + (define (parse-build-script-output port) + (define out (make-build-script-output '() '() '() '() '() '() '() '() '() '() '())) + (define (tick) + (define line (read-line port)) + (if (eof-object? line) + out + (begin (parse-build-script-line line out) (tick)))) + (tick)) + + (define (call-runner input-script cwd env) + (define output (store-path-for-ca-drv* "build.rs-run" "x86_64-linux" #~(#$runner-runner) #~(("script" . #$input-script) ("cwd" . #$cwd) ("OUT_DIR" . ,(make-placeholder "outdir")) . #$env) '("out" "outdir"))) + (printf "meow ~S\n" output) + (values (call-with-port (store-path-open (cdr (assoc "out" output))) parse-build-script-output) (cdr (assoc "outdir" output)))))) + diff --git a/lang/rust/src/cargo.sld b/lang/rust/src/cargo.sld new file mode 100644 index 0000000..ecb3579 --- /dev/null +++ b/lang/rust/src/cargo.sld @@ -0,0 +1,362 @@ +(define-library (zilch lang rust cargo) + (import + (scheme base) (scheme write) (scheme process-context) (scheme lazy) + (zilch file) (zilch magic) (zilch nix drv) (zilch nix path) (scheme char) + (zilch nixpkgs) (zilch zexpr) (zilch semver) + json + (chicken process) + (chicken base) (chicken format) + (chicken foreign) + (srfi 4) (srfi 128) (srfi 146) (srfi 152) (srfi 207) + (zilch lang rust registry) (zilch lang rust) (zilch lang rust cfg) + (zilch lang go vfs)) + + (export + make-cargo-target cargo-target? + cargo-target-name cargo-target-path cargo-target-test cargo-target-doctest + cargo-target-bench cargo-target-doc cargo-target-proc-macro cargo-target-harness + cargo-target-edition cargo-target-crate-type cargo-target-required-features + + make-cargo-dep-git cargo-dep-git? + cargo-dep-git-url cargo-dep-git-rev-type cargo-dep-git-rev + make-cargo-dep-path cargo-dep-path? cargo-dep-path-path + make-cargo-dep-registry cargo-dep-registry? cargo-dep-registry-name + + make-cargo-dependency cargo-dependency? + cargo-dependency-name cargo-dependency-origin cargo-dependency-version + cargo-dependency-default-features cargo-dependency-features cargo-dependency-package + cargo-dependency-optional + + make-cargo-crate cargo-crate? + cargo-crate-name cargo-crate-version cargo-crate-edition cargo-crate-dependencies + cargo-crate-features cargo-crate-lib-target cargo-crate-targets + cargo-crate-build-dependencies cargo-crate-build-script + cargo-crate-links + + parse-cargo-toml) + + (begin + (define linker (delay (let ((v (cdr (assoc "out" (nixpkgs "gcc"))))) #~,(string-append #$v "/bin/cc")))) + + ;; Shell out to a TOML-to-JSON parser. This will be replaced with a Nix-native solution later(tm). + (define (parse-toml toml-to-parse) + (define-values (read-port write-port pid) (process "yj" '("yj" "-tj"))) + (write-string toml-to-parse write-port) + (close-output-port write-port) + (define parsed (json-read read-port)) + (close-input-port read-port) + ; (define-values (_ _ _) (process-wait pid)) + parsed) + + ;; dependencies here is a list of (name . version-or-#f). if #f, use any version (should be unambiguous!) + (define-record-type + (make-cargo-target name path test doctest bench doc proc-macro harness edition crate-type required-features) + cargo-target? + (name cargo-target-name) ; required other than for [lib] + (path cargo-target-path) ; inferred + (test cargo-target-test) ; true for [lib, bin, test] + (doctest cargo-target-doctest) ; true for lib + (bench cargo-target-bench) ; true for lib, bin, benchmark + (doc cargo-target-doc) ; true for lib, bin + (proc-macro cargo-target-proc-macro) ; only valid for lib + (harness cargo-target-harness) ; defaults to true + (edition cargo-target-edition) ; defaults to package's edition field + (crate-type cargo-target-crate-type) ; [bin, lib, rlib, dylib, cdylib, staticlib, proc-macro] + (required-features cargo-target-required-features)) ; list. has no effect on lib + + (define-record-printer ( entry out) + (fprintf out "#" + (cargo-target-name entry) + (cargo-target-path entry) + (cargo-target-test entry) + (cargo-target-doctest entry) + (cargo-target-bench entry) + (cargo-target-doc entry) + (cargo-target-proc-macro entry) + (cargo-target-harness entry) + (cargo-target-edition entry) + (cargo-target-crate-type entry) + (cargo-target-required-features entry))) + + ; either: + ; - git + optionally tag/rev/branch (this supports looking at workspace.toml, as an exception) + ; - path (relative) + ; - no info (crates.io), or manual `registry` name (mapped using .cargo/config.toml) + ; + ; then also: + ; - version (optional other than for registry uses) + ; - default-features + ; - features + ; - package (used for resolving against the registry) + ; - optional (only if feature is enabled!) + ; or like, workspace (+ optional/features, whee) + + (define-record-type + (make-cargo-dep-git url rev-type rev) + cargo-dep-git? + (url cargo-dep-git-url) + (rev-type cargo-dep-git-rev-type) + (rev cargo-dep-git-rev)) + + (define-record-printer ( entry out) + (fprintf out "#" + (cargo-dep-git-url entry) + (cargo-dep-git-rev-type entry) + (cargo-dep-git-rev entry))) + + (define-record-type + (make-cargo-dep-path path) + cargo-dep-path? + (path cargo-dep-path-path)) + + (define-record-printer ( entry out) + (fprintf out "#" + (cargo-dep-path-path entry))) + + (define-record-type + (make-cargo-dep-registry name) + cargo-dep-registry? + (name cargo-dep-registry-name)) + (define-record-printer ( entry out) + (fprintf out "#" + (cargo-dep-registry-name entry))) + + (define-record-type + (make-cargo-dependency name origin version default-features features package optional) + cargo-dependency? + (name cargo-dependency-name) + (origin cargo-dependency-origin) + (version cargo-dependency-version) + (default-features cargo-dependency-default-features) + (features cargo-dependency-features) + (package cargo-dependency-package) + (optional cargo-dependency-optional)) + (define-record-printer ( entry out) + (fprintf out "#" + (cargo-dependency-name entry) + (cargo-dependency-origin entry) + (cargo-dependency-version entry) + (cargo-dependency-default-features entry) + (cargo-dependency-features entry) + (cargo-dependency-package entry) + (cargo-dependency-optional entry))) + + (define-record-type + (make-cargo-crate name version edition dependencies build-dependencies features lib-target build-script targets links) + cargo-crate? + (name cargo-crate-name) + (version cargo-crate-version) + (edition cargo-crate-edition) + (dependencies cargo-crate-dependencies) + (build-dependencies cargo-crate-build-dependencies) + (features cargo-crate-features) + (lib-target cargo-crate-lib-target) + (build-script cargo-crate-build-script) + (targets cargo-crate-targets) + (links cargo-crate-links)) + + (define-record-printer ( entry out) + (fprintf out "#" + (cargo-crate-name entry) + (cargo-crate-version entry) + (cargo-crate-edition entry) + (cargo-crate-dependencies entry) + (cargo-crate-features entry) + (cargo-crate-lib-target entry) + (cargo-crate-targets entry))) + + ; TODO(puck): aaaa + (define cfg-target "x86_64-unknown-linux-gnu") + (define cfg-values + '(( "debug_assertions" . #f) + ( "fmt_debug" . "full") + ( "overflow_checks" . #f) + ( "panic" . "unwind") + ( "relocation_model" . "pic") + ( "target_abi" . "") + ( "target_arch" . "x86_64") + ( "target_endian" . "little") + ( "target_env" . "gnu") + ( "target_family" . "unix") + ( "target_feature" . "fxsr") + ( "target_feature" . "sse") + ( "target_feature" . "sse2") + ( "target_has_atomic" . #f) + ( "target_has_atomic" . "16") + ( "target_has_atomic" . "32") + ( "target_has_atomic" . "64") + ( "target_has_atomic" . "8") + ( "target_has_atomic" . "ptr") + ( "target_has_atomic_equal_alignment" . "16") + ( "target_has_atomic_equal_alignment" . "32") + ( "target_has_atomic_equal_alignment" . "64") + ( "target_has_atomic_equal_alignment" . "8") + ( "target_has_atomic_equal_alignment" . "ptr") + ( "target_has_atomic_load_store" . #f) + ( "target_has_atomic_load_store" . "16") + ( "target_has_atomic_load_store" . "32") + ( "target_has_atomic_load_store" . "64") + ( "target_has_atomic_load_store" . "8") + ( "target_has_atomic_load_store" . "ptr") + ( "target_os" . "linux") + ( "target_pointer_width" . "64") + ( "target_thread_local" . #f) + ( "target_vendor" . "unknown") + ( "ub_checks" . #f) + ( "unix" . #f))) + + (define (cratify-name name) + ; NOTE! string-map _has_ to return a char. non-chars are mistreated and cause memory corruption. + ; TODO(puck): check this post-C6 + (string-map (lambda (v) (if (char=? v #\-) #\_ v)) name)) + + (define (and-cdr val) + (and val (cdr val))) + + (define (and-cdr-default val default) + (if val (cdr val) default)) + + (define (cargo-dependency-from-toml name object) + (define object-internals (vector->list object)) + (define version (and-cdr (assoc "version" object-internals))) + (define default-features (and-cdr-default (assoc "default-features" object-internals) #t)) + (define pkg-features (and-cdr-default (assoc "features" object-internals) '())) + (define package (or (and-cdr (assoc "package" object-internals)) name)) + (define optional (and-cdr (assoc "optional" object-internals))) + + (define git-url (and-cdr (assoc "git" object-internals))) + (define git-tag (and-cdr (assoc "tag" object-internals))) + (define git-rev (and-cdr (assoc "rev" object-internals))) + (define git-branch (and-cdr (assoc "branch" object-internals))) + + (define registry-name (and-cdr (assoc "registry" object-internals))) + (define path (and-cdr (assoc "path" object-internals))) + + (define origin (cond + (path (make-cargo-dep-path path)) + (registry-name (make-cargo-dep-registry registry-name)) + ((and git-url git-tag) (make-cargo-dep-git git-url 'tag git-tag)) + ((and git-url git-rev) (make-cargo-dep-git git-url 'rev git-rev)) + ((and git-url git-branch) (make-cargo-dep-git git-url 'branch git-branch)) + (git-url (make-cargo-dep-git git-url #f #f)) + (else (make-cargo-dep-registry #f)))) + (make-cargo-dependency name origin version default-features pkg-features package optional)) + + ;; base-type is lib/bin/example/test/benchmark + (define (cargo-target-from-toml object crate-name base-type base-edition) + (define object-internals (vector->list object)) + + (unless (or (eq? base-type 'lib) (assoc "name" object-internals)) (error "cargo target has no name")) + (define name (or (and-cdr (assoc "name" object-internals)) (cratify-name crate-name))) + (define path (or (and-cdr (assoc "path" object-internals)) + (case base-type + ((lib) "src/lib.rs") + ;; TODO(puck): multi-file + ((bin) (string-append "src/bin/" name ".rs")) + ((example) (string-append "examples/" name ".rs")) + ((test) (string-append "tests/" name ".rs")) + ((benchmark) (string-append "benches/" name ".rs"))))) + (define test (and-cdr-default (assoc "test" object-internals) (member base-type '(lib bin test)))) + (define doctest (and-cdr-default (assoc "doctest" object-internals) (eq? base-type 'lib))) + (define bench (and-cdr-default (assoc "bench" object-internals) (member base-type '(lib bin benchmark)))) + (define doc (and-cdr-default (assoc "doc" object-internals) (member base-type '(lib bin)))) + (define proc-macro (and (eq? base-type 'lib) (and-cdr (assoc "proc-macro" object-internals)))) + (define harness (and-cdr-default (assoc "harness" object-internals) #t)) + (define edition (or (and-cdr (assoc "edition" object-internals)) base-edition)) + (define crate-type (if (assoc "crate-type" object-internals) + (map string->symbol (cdr (assoc "crate-type" object-internals))) + (cond + (proc-macro 'proc-macro) + ((eq? base-type 'lib) 'lib) + ((eq? base-type 'example) 'bin) + (else 'bin)))) + (define required-features (or (and-cdr (assoc "required-features" object-internals)) '())) + + (make-cargo-target name path test doctest bench doc proc-macro harness edition crate-type required-features)) + + ; A feature is two parts: ((crate-name . activates-crate) package-feature) + ; "dep:foo" resolves to (("foo" . #t) . #f) + ; "foo/bar" resolves to (("foo" . #t) . "bar") + ; "foo?/bar" resolves to (("foo" . #f) . "bar") + + (define (parse-features feature-alist dependency-names) + (define needs-implicit-dependency (mapping (make-default-comparator))) + (for-each (lambda (name) (set! needs-implicit-dependency (mapping-set! needs-implicit-dependency name #t))) dependency-names) + + (define (parse-feature-string str) + (if (string-prefix? "dep:" str) + (let ((name (string-copy str 4))) + (set! needs-implicit-dependency (mapping-set! needs-implicit-dependency name #f)) + (cons name (cons #t #f))) + (let* ((index (string-contains str "/")) + (first-half (if index (string-copy str 0 index) str)) + (second-half (and index (string-copy str (+ index 1)))) + (first-half-is-optional (string-suffix? "?" first-half)) + (first-half-not-optional (if first-half-is-optional (string-copy str 0 (- index 1)) first-half))) + (if second-half + (cons first-half-not-optional (cons (not first-half-is-optional) second-half)) + (cons #f (cons #t first-half)))))) + + (define parsed (map (lambda (kv) (cons (car kv) (map parse-feature-string (cdr kv)))) feature-alist)) + (mapping-for-each (lambda (k v) (when v (set! parsed (cons (list k (cons k (cons #t #f))) parsed)))) needs-implicit-dependency) + parsed) + + (define (parse-cargo-toml vfs cargo-file) + (define internals (vector->list (parse-toml cargo-file))) + (define package (vector->list (cdr (assoc "package" internals)))) + (define package-name (cdr (assoc "name" package))) + (define package-version (cdr (assoc "version" package))) + (define package-links (and-cdr (assoc "links" package))) + (define package-edition (or (and-cdr (assoc "edition" package)) "2015")) + + (unless (and vfs (vfs? vfs)) + (set! vfs #f)) + + (define lib-target #f) + ;; TODO(puck): lack-of-vfs workarounds + (when (or (assoc "lib" internals) (if vfs (vfs-file-ref vfs "src" "lib.rs") #t)) + (set! lib-target (cargo-target-from-toml (or (and-cdr (assoc "lib" internals)) #()) package-name 'lib package-edition))) + + (define other-targets '()) + (when (and vfs (vfs-file-ref vfs "src" "main.rs")) + (set! other-targets (cons (cargo-target-from-toml (vector (cons "name" package-name) (cons "path" "src/main.rs")) package-name 'bin package-edition) other-targets))) + + (define build-file-path (and-cdr (assoc "build" package))) + (define build-script-target #f) + (when build-file-path + (set! build-script-target (make-cargo-target (cratify-name (string-append package-name "_buildscript")) build-file-path #f #f #f #f #f #f "2021" 'bin '("default")))) + + (define dependencies + (map + (lambda (kv) + (cargo-dependency-from-toml (car kv) (if (string? (cdr kv)) (vector (cons "version" (cdr kv))) (cdr kv)))) + (vector->list (or (and-cdr (assoc "dependencies" internals)) #())))) + + ;; TODO(puck): target.{matching cfg}.build-dependencies??? + (define build-dependencies + (map + (lambda (kv) + (cargo-dependency-from-toml (car kv) (if (string? (cdr kv)) (vector (cons "version" (cdr kv))) (cdr kv)))) + (vector->list (or (and-cdr (assoc "build-dependencies" internals)) #())))) + + ; Merge in dependencies in target.{matching cfg or target}.dependencies? + (for-each + (lambda (target-pair) + (define target (car target-pair)) + (define contents (cdr target-pair)) + (define matches + (if (and (string-prefix? "cfg(" target) (string-suffix? ")" target)) + (cfg-matches (cfg-parse (string-copy target 4 (- (string-length target) 1))) cfg-values) + (string=? target cfg-target))) + (when matches + (set! dependencies + (append + (map + (lambda (kv) + (cargo-dependency-from-toml (car kv) (if (string? (cdr kv)) (vector (cons "version" (cdr kv))) (cdr kv)))) + (vector->list (or (and-cdr (assoc "dependencies" (vector->list contents))) #()))) + dependencies)))) + (vector->list (or (and-cdr (assoc "target" internals)) #()))) + + (define own-features (parse-features (vector->list (or (and-cdr (assoc "features" internals)) #())) (map cargo-dependency-name dependencies))) + (make-cargo-crate package-name package-version package-edition dependencies build-dependencies own-features lib-target build-script-target other-targets package-links)))) diff --git a/lang/rust/src/cfg.sld b/lang/rust/src/cfg.sld new file mode 100644 index 0000000..f11e195 --- /dev/null +++ b/lang/rust/src/cfg.sld @@ -0,0 +1,124 @@ +(define-library (zilch lang rust cfg) + (import + (scheme base) + (srfi 152)) + + (export cfg-parse cfg-matches) + + (begin + (define (is-ident-start ch) + (or + (char=? ch #\_) + (and (char>=? ch #\A) (char<=? ch #\Z)) + (and (char>=? ch #\a) (char<=? ch #\z)))) + + (define (is-ident-rest ch) + (or + (is-ident-start ch) + (and (char>=? ch #\0) (char<=? ch #\9)))) + + (define (tokenize-cfg strval index tail) + (if (>= index (string-length strval)) + (reverse tail) + (case (string-ref strval index) + ((#\space) (tokenize-cfg strval (+ index 1) tail)) + ((#\x28) (tokenize-cfg strval (+ index 1) (cons 'left-paren tail))) + ((#\x29) (tokenize-cfg strval (+ index 1) (cons 'right-paren tail))) + ((#\,) (tokenize-cfg strval (+ index 1) (cons 'comma tail))) + ((#\=) (tokenize-cfg strval (+ index 1) (cons 'equals tail))) + ((#\") + (let ((end (string-index strval (lambda (f) (char=? f #\")) (+ index 1)))) + (unless end (error "Unterminated string in cfg() string" strval)) + (tokenize-cfg strval (+ end 1) (cons (string-copy strval (+ index 1) end) tail)))) + (else + (if (is-ident-start (string-ref strval index)) + (let ((end (or (string-skip strval is-ident-rest (+ index 1)) (string-length strval)))) + (tokenize-cfg strval end (cons (cons 'ident (string-copy strval index end)) tail))) + (error "Unexpected character in cfg() string" strval)))))) + (define (cfg-parse str) + (define tokens (tokenize-cfg str 0 '())) + (define (expect token) + (when (null? tokens) + (error "Unexpected EOF parsing cfg() string")) + (unless (equal? token (car tokens)) + (error "Unexpected token" (cons (car tokens) token))) + (set! tokens (cdr tokens))) + (define (next) + (define tok (car tokens)) + (set! tokens (cdr tokens)) + tok) + (define (parse-cfg) + (when (null? tokens) + (error "Unexpected EOF parsing cfg() string")) + (define token (next)) + (unless (and (pair? token) (equal? (car token) 'ident)) + (error "Unexpected token, expected identifier" token)) + (if (and (not (null? tokens)) (equal? (car tokens) 'equals)) + (begin + (next) + (let ((str-token (next))) + (unless (string? str-token) + (error "Unexpected token parsing cfg=, expected string" str-token)) + (values (cdr token) str-token))) + (values (cdr token) #f))) + + ; Also consumes the right paren. + (define (parse-comma-separated-expr tail) + (when (null? tokens) + (error "Unexpected EOF parsing cfg() expression contents")) + (if (equal? (car tokens) 'right-paren) + (begin (next) (reverse tail)) + (let ((parsed (parse-expr))) + (if (or (null? tokens) (equal? (car tokens) 'comma)) + (begin (expect 'comma) (parse-comma-separated-expr (cons parsed tail))) + (begin (expect 'right-paren) (reverse (cons parsed tail))))))) + (define (parse-expr) + (when (null? tokens) + (error "Unexpected EOF parsing cfg() expression")) + (define token (car tokens)) + (unless (and (pair? token) (equal? (car token) 'ident)) + (error "Unexpected token, expected identifier" token)) + (cond + ((string=? (cdr token) "all") + (next) + (expect 'left-paren) + (let ((tokens (parse-comma-separated-expr '()))) + (cons 'all tokens))) + ((string=? (cdr token) "any") + (next) + (expect 'left-paren) + (let ((tokens (parse-comma-separated-expr '()))) + (cons 'any tokens))) + ((string=? (cdr token) "not") + (next) + (expect 'left-paren) + (let ((expr (parse-expr))) + (expect 'right-paren) + (cons 'not expr))) + (else + (let-values (((left right) (parse-cfg))) + (cons 'value (cons left right)))))) + (parse-expr)) + + (define (cfg-matches expr cfgs) + (define (parse-any tail) + (cond + ((null? tail) #f) + ((cfg-matches (car tail) cfgs) #t) + (else (parse-any (cdr tail))))) + (define (parse-all tail) + (cond + ((null? tail) #t) + ((not (cfg-matches (car tail) cfgs)) #f) + (else (parse-all (cdr tail))))) + (define (has-match-in-cfg pair tail) + (cond + ((null? tail) #f) + ((equal? pair (car tail)) #t) + (else (has-match-in-cfg pair (cdr tail))))) + (case (car expr) + ((value) (has-match-in-cfg (cdr expr) cfgs)) + ((any) (parse-any (cdr expr))) + ((all) (parse-all (cdr expr))) + ((not) (not (cfg-matches (cdr expr) cfgs))) + (else (error "unknown cfg expression" expr)))))) diff --git a/lang/rust/src/registry.sld b/lang/rust/src/registry.sld new file mode 100644 index 0000000..5d33bc9 --- /dev/null +++ b/lang/rust/src/registry.sld @@ -0,0 +1,82 @@ +(define-library (zilch lang rust registry) + (import + (scheme base) (scheme write) (scheme process-context) (scheme lazy) + (zilch file) (zilch magic) (zilch nix drv) (zilch nix path) + (zilch nixpkgs) (zilch zexpr) + json + (chicken process) + (chicken base) (chicken format) + (chicken foreign) + (srfi 4) (srfi 152) (srfi 207)) + + (export + parse-lockfile fetch-and-unpack-crate + + lockfile-entry? lockfile-entry-name lockfile-entry-version lockfile-entry-source lockfile-entry-checksum lockfile-entry-dependencies) + + (begin + ;; Shell out to a TOML-to-JSON parser. This will be replaced with a Nix-native solution later(tm). + (define (parse-toml toml-to-parse) + (define-values (read-port write-port pid) (process "yj" '("yj" "-tj"))) + (write-string toml-to-parse write-port) + (close-output-port write-port) + (define parsed (json-read read-port)) + (close-input-port read-port) + ; (define-values (_ _ _) (process-wait pid)) + parsed) + + ;; TODO(puck): source here should probably be a record? + ;; dependencies here is a list of (name . version-or-#f). if #f, use any version (should be unambiguous!) + (define-record-type + (make-lockfile-entry name version source checksum dependencies) + lockfile-entry? + (name lockfile-entry-name) + (version lockfile-entry-version) + (source lockfile-entry-source) + (checksum lockfile-entry-checksum) + (dependencies lockfile-entry-dependencies)) + + (define-record-printer ( entry out) + (fprintf out "#" + (lockfile-entry-name entry) + (lockfile-entry-version entry) + (lockfile-entry-source entry) + (lockfile-entry-checksum entry) + (lockfile-entry-dependencies entry))) + + (define (fetch-and-unpack-crate lockfile-entry) + (unless (string=? (lockfile-entry-source lockfile-entry) "registry+https://github.com/rust-lang/crates.io-index") (error "unknown source " (lockfile-entry-source lockfile-entry))) + + ; TODO(puck): hardcoded + (define url (string-append "https://static.crates.io/crates/" (lockfile-entry-name lockfile-entry) "/" (lockfile-entry-version lockfile-entry) "/download")) + (define crate-name (string-append (lockfile-entry-name lockfile-entry) "-" (lockfile-entry-version lockfile-entry) ".crate")) + (define crate-name-path (string-append (lockfile-entry-name lockfile-entry) "-" (lockfile-entry-version lockfile-entry))) + (define fetched-tarball (store-path-for-fod crate-name "builtin" '("builtin:fetchurl") `(("url" . ,url)) "sha256" (lockfile-entry-checksum lockfile-entry) #f)) + (define unpacked-tarball + (cdar (store-path-for-drv crate-name "builtin" '("builtin:unpack-channel") + #~(("src" . #$fetched-tarball) + ("channelName" . #$crate-name-path)) '("out")))) + #~,(string-append #$unpacked-tarball "/" #$crate-name-path)) + + (define (parse-lockfile file-contents) + (define inputs (vector->list (parse-toml file-contents))) + (define lockfile-version (assoc "version" inputs)) + (unless (and lockfile-version (>= (cdr lockfile-version) 3)) (error "Unknown lockfile version" lockfile-version)) + (define packages (assoc "package" inputs)) + (map + (lambda (package) + (define alist (vector->list package)) + (define name (assoc "name" alist)) + (define version (assoc "version" alist)) + (define source (assoc "source" alist)) + (define checksum (assoc "checksum" alist)) + (define dependencies (assoc "dependencies" alist)) + + (define processed-dependencies + (if dependencies + (map (lambda (dep) + (define index (string-contains dep " ")) + (if index (cons (string-copy dep 0 index) (string-copy dep (+ index 1))) (cons dep #f))) (cdr dependencies)) + '())) + (make-lockfile-entry (cdr name) (cdr version) (and source (cdr source)) (and checksum (hex-string->bytevector (cdr checksum))) processed-dependencies)) + (if packages (cdr packages) '()))))) diff --git a/lang/rust/src/resolver.sld b/lang/rust/src/resolver.sld new file mode 100644 index 0000000..5d54d40 --- /dev/null +++ b/lang/rust/src/resolver.sld @@ -0,0 +1,493 @@ +(define-library (zilch lang rust resolver) + (import + (scheme base) (scheme write) (scheme process-context) (scheme lazy) + (zilch file) (zilch magic) (zilch nix drv) (zilch nix path) (scheme char) + (zilch nixpkgs) (zilch zexpr) (zilch semver) + json + (chicken process) + (chicken base) (chicken format) + (chicken foreign) + (srfi 4) (srfi 128) (srfi 146) (srfi 152) (srfi 207) + (zilch lang rust registry) (zilch lang rust) (zilch lang rust cargo) (zilch lang rust build-script) + (zilch lang go vfs)) + + (export + make-resolver resolver? resolver-locked-dependencies resolver-selected-dependencies + make-resolved-package-build-data resolved-package-build-data? + resolved-package-build-data-dep-info resolved-package-build-data-metadata resolved-package-build-data-rlib + resolved-package-build-data-transitive-dependencies + + make-resolved-package resolved-package? + resolved-package-name resolved-package-version resolved-package-fs + resolved-package-cargo-target resolved-package-enabled-features resolved-package-dependencies + resolved-package-build-data + + resolver-download + resolver-resolve-nonoptional + resolver-resolve-resolved-package + resolver-activate-features + resolver-register + resolver-resolve + resolver-print-pkg + resolver-print + process-cargo-with-lockfile + build-package) + + (begin + (define gcc (delay (cdr (assoc "out" (nixpkgs "gcc"))))) + (define linker (delay #~,(string-append #$(force gcc) "/bin/cc"))) + + (define pkgconfig (delay (cdr (assoc "out" (nixpkgs "pkg-config"))))) + (define openssl (delay (let ((data (nixpkgs "openssl"))) #~,(begin #$(cdr (assoc "out" data)) #$(cdr (assoc "dev" data)))))) + + (define (build-script-env-overrides-for-crate crate-name) + (cond + ((string=? crate-name "openssl-sys") + #~(("PATH" . ,(string-append #$(force pkgconfig) "/bin:" #$(force gcc) "/bin")) ("PKG_CONFIG_PATH" . ,(string-append #$(force openssl) "/lib/pkgconfig")))) + (else '()))) + + + ; Used to select a set of crates plus their versions. + (define-record-type + ; locked-dependencies is a mapping of package-name to a mapping of version to (version . (lockfile-entry . unpack-promise)) + ; selected-dependencies is a mapping of package-name to a list of (version . resolved-package)(?) + (make-resolver locked-dependencies selected-dependencies) + resolver? + (locked-dependencies resolver-locked-dependencies set-resolver-locked-dependencies!) + (selected-dependencies resolver-selected-dependencies set-resolver-selected-dependencies!)) + + (define-record-type + (make-resolved-package-build-data dep-info metadata rlib transitive-dependencies build-script-metadata bin-flags) + resolved-package-build-data? + (dep-info resolved-package-build-data-dep-info set-resolved-package-build-data-dep-info!) + (metadata resolved-package-build-data-metadata set-resolved-package-build-data-metadata!) + (rlib resolved-package-build-data-rlib set-resolved-package-build-data-rlib!) + (transitive-dependencies resolved-package-build-data-transitive-dependencies set-resolved-package-build-data-transitive-dependencies!) + (build-script-metadata resolved-package-build-data-build-script-metadata) + (bin-flags resolved-package-build-data-bin-flags)) + + (define-record-type + (make-resolved-package name version fs cargo-target target-dependencies crate enabled-features dependencies build-data build-script) + resolved-package? + (name resolved-package-name) + (version resolved-package-version) + (fs resolved-package-fs) + (cargo-target resolved-package-cargo-target) + (target-dependencies resolved-package-target-dependencies) + (crate resolved-package-crate) + (enabled-features resolved-package-enabled-features set-resolved-package-enabled-features!) + (dependencies resolved-package-dependencies set-resolved-package-dependencies!) + (build-data resolved-package-build-data set-resolved-package-build-data!) + (build-script resolved-package-build-script set-resolved-package-build-script!)) + + ;; Download and activate a dependency from the registry. + (define (resolver-download resolver name version) + (define vfs (force (cddr (mapping-ref (mapping-ref (resolver-locked-dependencies resolver) name) (version-str version))))) + (define parsed-cargo (parse-cargo-toml vfs (call-with-port (store-path-open #~,(string-append #$vfs "/Cargo.toml")) (lambda (p) (read-string 99999999 p))))) + (unless (cargo-crate-lib-target parsed-cargo) + (error "Crate does not have valid [lib] target" (list name version))) + + (define build-script #f) + (when (cargo-crate-build-script parsed-cargo) + (set! build-script (make-resolved-package (string-append name "_build") version vfs (cargo-crate-build-script parsed-cargo) (cargo-crate-build-dependencies parsed-cargo) parsed-cargo '() (mapping (make-default-comparator)) #f #f)) + (resolver-resolve-nonoptional resolver build-script)) + + (define pkg (make-resolved-package (string-copy name) version vfs (cargo-crate-lib-target parsed-cargo) (cargo-crate-dependencies parsed-cargo) parsed-cargo '() (mapping (make-default-comparator)) #f build-script)) + + ; Add package to the mapping. + (define existing-mapping (mapping-ref/default (resolver-selected-dependencies resolver) name '())) + (set-resolver-selected-dependencies! resolver (mapping-set (resolver-selected-dependencies resolver) name (cons (cons version pkg) existing-mapping))) + (resolver-resolve-nonoptional resolver pkg) + pkg) + + ;; Preemptively resolve and activate all dependencies not marked optional. + (define (resolver-resolve-nonoptional resolver pkg) + (for-each + (lambda (dep) + (unless (cargo-dependency-optional dep) + (resolver-resolve-resolved-package resolver pkg (cargo-dependency-name dep) #t))) + (resolved-package-target-dependencies pkg))) + + + ;; Resolve a name of a dependency of a , activating it if `activate` is #t. + (define (resolver-resolve-resolved-package resolver pkg name activate) + (define resolved-dep (mapping-ref/default (resolved-package-dependencies pkg) name #f)) + (define cargo-dep + (do + ((l (resolved-package-target-dependencies pkg) (cdr l))) + ((or (eq? l '()) (string=? (cargo-dependency-name (car l)) name)) (and (pair? l) (car l))))) + ; TODO(puck): Somehow this is okay? there might be more complex guarantees involved here? WAS: (error "Could not find dependency" (list (resolved-package-name pkg) (resolved-package-version pkg) name)))) + (when (and activate cargo-dep (not resolved-dep)) + (set! resolved-dep (resolver-resolve resolver cargo-dep)) + (set-resolved-package-dependencies! pkg (mapping-set! (resolved-package-dependencies pkg) name resolved-dep)) + (when (cargo-dependency-default-features cargo-dep) (resolver-activate-features resolver resolved-dep '("default"))) + (when (cargo-dependency-features cargo-dep) (resolver-activate-features resolver resolved-dep (cargo-dependency-features cargo-dep)))) + resolved-dep) + + ;; Activate a series of features on an existing . This will resolve and activate optional dependencies + ;; where needed. + (define (resolver-activate-features resolver resolved to-activate) + (for-each + (lambda (feature) + (unless (member feature (resolved-package-enabled-features resolved)) + ; Activate the feature. + (set-resolved-package-enabled-features! resolved (cons feature (resolved-package-enabled-features resolved))) + (when (resolved-package-build-script resolved) + (set-resolved-package-enabled-features! (resolved-package-build-script resolved) (cons feature (resolved-package-enabled-features (resolved-package-build-script resolved))))) + + ; Follow each activation of the feature. + (for-each + (lambda (activation) + ; TODO: if dep isn't activated and has optional dep, track it! + (let ((involved-dep (and (car activation) (resolver-resolve-resolved-package resolver resolved (car activation) (cadr activation))))) + (when (and (cddr activation) involved-dep) (resolver-activate-features resolver involved-dep (list (cddr activation)))) + (when (and (not (car activation)) (cddr activation)) (resolver-activate-features resolver resolved (list (cddr activation)))))) + (cdr (or (assoc feature (cargo-crate-features (resolved-package-crate resolved))) (cons '() '())))))) + to-activate)) + + ;; Register a non-registry crate+vfs with the resolver. + (define (resolver-register resolver vfs crate) + (define target (cargo-crate-lib-target crate)) + (unless target + (set! target (car (cargo-crate-targets crate)))) + (define build-script #f) + (when (cargo-crate-build-script crate) + (set! build-script (make-resolved-package (string-append (cargo-target-name target) "_build") (parse-version (cargo-crate-version crate)) vfs (cargo-crate-build-script crate) (cargo-crate-build-dependencies crate) crate '() (mapping (make-default-comparator)) #f #f)) + (resolver-resolve-nonoptional resolver build-script)) + (define pkg (make-resolved-package (cargo-target-name target) (parse-version (cargo-crate-version crate)) vfs target (cargo-crate-dependencies crate) crate '() (mapping (make-default-comparator)) #f build-script)) + (define existing-mapping (mapping-ref/default (resolver-selected-dependencies resolver) (cargo-target-name target) '())) + (set-resolver-selected-dependencies! resolver (mapping-set (resolver-selected-dependencies resolver) (cargo-target-name target) (cons (cons (parse-version (cargo-crate-version crate)) pkg) existing-mapping))) + (resolver-resolve-nonoptional resolver pkg) + pkg) + + ;; Resolves a , returning the . + (define (resolver-resolve resolver dep) + (define package-name (cargo-dependency-package dep)) + (define requirements (apply append (map parse-version-requirement (string-split (cargo-dependency-version dep) "," 'strict-infix)))) + (define existing-mapping (mapping-ref/default (resolver-selected-dependencies resolver) package-name '())) + (define available-versions (mapping-ref (resolver-locked-dependencies resolver) package-name)) + (define (find-matching-version l best-version) + (cond + ((eq? l '()) best-version) + ((matches-requirements (caar l) requirements) + (find-matching-version (cdr l) (if (and best-version (versionstring (version-major (resolved-package-version resolved)))) + ("CARGO_PKG_VERSION_MINOR" . ,(number->string (version-minor (resolved-package-version resolved)))) + ("CARGO_PKG_VERSION_PATCH" . ,(number->string (version-patch (resolved-package-version resolved)))) + ("CARGO_PKG_VERSION_PRE" . ,(string-join (or (version-prerelease (resolved-package-version resolved)) '()) ".")) + ("CARGO_PKG_AUTHORS" . "") + ("CARGO_PKG_NAME" . ,(cargo-crate-name (resolved-package-crate resolved))) + ("CARGO_PKG_DESCRIPTION" . "") + ("CARGO_PKG_HOMEPAGE" . "") + ("CARGO_PKG_REPOSITORY" . "") + ("CARGO_PKG_LICENSE" . "") + ("CARGO_PKG_LICENSE_FILE" . "") + ("CARGO_PKG_RUST_VERSION" . "") + ("CARGO_PKG_README" . "") + ("CARGO_CRATE_NAME" . ,crate-name))) + ; CARGO_BIN_NAME, OUT_DIR, CARGO_BIN_EXE_*: skipping for now + ; CARGO_PRIMARY_PACKAGE: not sensible here + ; CARGO_TARGET_TMPDIR: integration/benchmark only + ; CARGO_RUSTC_CURRENT_DIR: nightly only + + (define (upcase-underscore ch) + (if (char=? ch #\-) #\_ (char-upcase ch))) + + (when (resolved-package-build-script resolved) + (unless (resolved-package-build-data (resolved-package-build-script resolved)) + (build-package (resolved-package-build-script resolved))) + (mapping-for-each + (lambda (key value) + (unless (resolved-package-build-data value) + (build-package value)) + (for-each + (lambda (kv) + (set! dependency-metadata (cons (cons (string-map upcase-underscore (string-append "DEP_" (cargo-crate-links (resolved-package-crate value)) "_" (car kv))) (cdr kv)) dependency-metadata))) + (resolved-package-build-data-build-script-metadata (resolved-package-build-data value)))) + (resolved-package-dependencies resolved)) + (let*-values + (((build-script) (cdr (resolved-package-build-data-rlib (resolved-package-build-data (resolved-package-build-script resolved))))) + ((build-script-env) (build-script-env-overrides-for-crate (cargo-crate-name (resolved-package-crate resolved)))) + ((runner-output runner-outdir) + (call-runner build-script crate-root + #~( + ("RUSTC" . ,(string-append #$rustc "/bin/rustc")) + ("HOST" . "x86_64-unknown-linux-gnu") + ("TARGET" . "x86_64-unknown-linux-gnu") + ("OPT_LEVEL" . "0") + ("PROFILE" . "debug") + ("DEBUG" . "true") + ,@dependency-metadata + #$@build-script-env + ; TODO: OUT_DIR, NUM_JOBS, OPT_LEVEL/DEBUG/PROFILE, DEP_* + ; RUSTC/RUSTDOC?, RUSTC_LINKER? and CARGO_ENCODED_RUSTFLAGS + . #$rustc-env)))) + (printf "runner output for ~S: ~S\n" (cargo-crate-name (resolved-package-crate resolved)) runner-output) + (map + (lambda (v) + (if (pair? v) + (set! params `(#:cfg ,(string-append (car v) "=\"" (cdr v) "\"") . ,params)) + (set! params `(#:cfg ,v . ,params)))) + (build-script-output-cfg runner-output)) + (set! buildscript-metadata (build-script-output-metadata runner-output)) + (let ((old-rustc-env rustc-env)) + (set! rustc-env #~(("OUT_DIR" . #$runner-outdir) . #$old-rustc-env))) + ; Reverse order for scheme reasons. + (for-each + (lambda (kv) (set! bin-flags `(#:link ,kv . ,bin-flags))) + (build-script-output-link-lib runner-output)) + + ; TODO(puck): hack to workaround lack of store path passthrough + ; This should be replaced with .... $something (a dir of all build script outputs?) + (unless (or (null? build-script-env) (null? bin-flags)) + (let ((v (cadr bin-flags))) + (set-cdr! bin-flags (cons #~,(begin #$build-script-env v) (cddr bin-flags))))) + (for-each + (lambda (kv) (set! bin-flags `(#:search-path ,kv . ,bin-flags))) + (build-script-output-link-search runner-output)) + (printf "~S bin flags: ~S\n" (cargo-crate-name (resolved-package-crate resolved)) bin-flags))) + ; TODO(puck): check-cfg wants check-cfg everywhere + ;(map + ; (lambda (v) + ; (set! params `(#:check-cfg ,v . ,params))) + ; (build-script-output-check-cfg runner-output)))) + + (define params-meta params) + (define transitive-dependencies '()) + (mapping-for-each + (lambda (key value) + (unless (resolved-package-build-data value) + (build-package value)) + (for-each (lambda (dep) (unless (member dep transitive-dependencies) (set! transitive-dependencies (cons dep transitive-dependencies)))) (resolved-package-build-data-transitive-dependencies (resolved-package-build-data value))) + (unless (member value transitive-dependencies) (set! transitive-dependencies (cons value transitive-dependencies))) + (define data (resolved-package-build-data value)) + (define meta-or-rlib (or (resolved-package-build-data-metadata data) (resolved-package-build-data-rlib data))) + (set! params-meta + `(#:externs (,(cratify-name key) . ,(cdr meta-or-rlib)) . ,params-meta)) + (set! params + `(#:externs (,(cratify-name key) . ,(cdr (resolved-package-build-data-rlib data))) . ,params))) + (resolved-package-dependencies resolved)) + + (define transitive-dependencies-meta + (zdir (map (lambda (dep) + (define data (resolved-package-build-data dep)) + (define meta-or-rlib (or (resolved-package-build-data-metadata data) (resolved-package-build-data-rlib data))) + (cons + (car meta-or-rlib) + (zsymlink (cdr meta-or-rlib)))) transitive-dependencies))) + (define transitive-dependencies-rlib + (zdir (map (lambda (dep) + (define data (resolved-package-build-data dep)) + (define rlib (resolved-package-build-data-rlib data)) + (cons + (car rlib) + (zsymlink (cdr rlib)))) transitive-dependencies))) + + (define transitive-bin-flags '()) + (for-each (lambda (dep) (set! transitive-bin-flags (append (resolved-package-build-data-bin-flags (resolved-package-build-data dep)) transitive-bin-flags))) transitive-dependencies) + + (unless (eq? crate-type 'rlib) + (set! params `(codegen-flags: ("linker" . ,(force linker)) . ,params))) + + (define path #~,(string-append #$(if (vfs? (resolved-package-fs resolved)) (vfs-to-store (resolved-package-fs resolved)) (resolved-package-fs resolved)) "/" (cargo-target-path (resolved-package-cargo-target resolved)))) + (define dep-info (cdar (apply call-rustc `(,path ,rustc-env search-path: ("dependency" . ,transitive-dependencies-meta) emits: (dep-info: #t) . ,params-meta)))) + + (define rlib-name (string-append "lib" crate-name "-v" crate-version ".rlib")) + (define rmeta-name (string-append "lib" crate-name "-v" crate-version ".rmeta")) + + (when (eq? crate-type 'proc-macro) + (set! rlib-name (string-append "lib" crate-name "-v" crate-version ".so"))) + + (when (or (eq? crate-type 'proc-macro) (eq? crate-type 'bin)) + (set! params (append transitive-bin-flags params))) + (when (eq? crate-type 'bin) + (set! params `(#:codegen-flags ("rpath" . "no") . ,params))) + + ; Rust is nitpicky about the filenames, fix them with copious symlinking. + (define rlib-file (cdar (apply call-rustc `(,path ,rustc-env search-path: ("dependency" . ,transitive-dependencies-rlib) emits: (link: #t) ,@bin-flags . ,params)))) + (define rlib (cons rlib-name #~,(string-append #$(zdir rlib-name (zsymlink rlib-file)) "/" rlib-name))) + (store-path-materialize rlib-file) + + (define metadata #f) + (define metadata-file #f) + (unless (eq? crate-type 'proc-macro) + (set! metadata-file (cdar (apply call-rustc `(,path ,rustc-env search-path: ("dependency" . ,transitive-dependencies-meta) emits: (metadata: #t) . ,params-meta)))) + (set! metadata (cons rmeta-name #~,(string-append #$(zdir rmeta-name (zsymlink metadata-file)) "/" rmeta-name))) + (store-path-materialize metadata-file)) + + (printf "-> crate ~S: ~S/~S/~S\n" crate-name dep-info metadata-file rlib-file) + (set-resolved-package-build-data! resolved (make-resolved-package-build-data dep-info metadata rlib transitive-dependencies buildscript-metadata bin-flags)) + (list dep-info metadata rlib)) + + (define (matches-requirements ver req) + (if (eq? req '()) + #t + (and + (case (caar req) + ((<) (version) (version=) (or (version=? ver (cdar req)) (version=" str) + (set! type '>=) + (set! str (string-copy str 2))) + (when (string-prefix? ">" str) + (set! type '>) + (set! str (string-copy str 1))) + (when (string-prefix? "~" str) + (set! type '~) + (set! str (string-copy str 1))) + (when (string-prefix? "<=" str) + (set! type '<=) + (set! str (string-copy str 2))) + (when (string-prefix? "<" str) + (set! type '<) + (set! str (string-copy str 1))) + (when (string-prefix? "=" str) + (set! type '=) + (set! str (string-copy str 1))) + (when (string-prefix? "^" str) + (set! type '^) + (set! str (string-copy str 1))) + (set! str (string-copy str (string-skip str char-whitespace?))) + (let ((suffix-len (string-suffix-length ".*" str))) + (when (> suffix-len 0) + (set! type '~) + (set! str (string-copy str 0 (- (string-length str) suffix-len))))) + (define-values (parsed-version part-count) + (let* + ((first-period (string-index str (lambda (v) (char=? v #\.)))) + (second-period (and first-period (string-index str (lambda (v) (char=? v #\.)) (+ first-period 1))))) + (cond + ((and first-period second-period) (values (parse-version str) 3)) + (first-period (values (parse-version (string-append str ".0")) 2)) + ((string=? str "") (values (parse-version "0.0.0") 0)) + (else (values (parse-version (string-append str ".0.0")) 1))))) + (define (first-incompatible ver) + (if (= (version-major ver) 0) + (make-version 0 (+ (version-minor ver) 1) 0 '("0") #f) + (make-version (+ (version-major ver) 1) 0 0 '("0") #f))) + (define (next-major ver) + (make-version (+ (version-major ver) 1) 0 0 '("0") #f)) + (define (next-minor ver) + (make-version (version-major ver) (+ (version-minor ver) 1) 0 '("0") #f)) + (define (exclude-prerelease ver) + (if (version-prerelease ver) + ver + (make-version (version-major ver) (version-minor ver) (version-patch ver) '("0") #f))) + (case type + ((^) (list (cons '>= parsed-version) (cons '< (first-incompatible parsed-version)))) + ((~) (if (= part-count 0) + (list + (cons '>= parsed-version)) + (list + (cons '>= parsed-version) + (cons '< (case part-count + ((2 3) (next-minor parsed-version)) + ((1) (next-major parsed-version))))))) + ; TODO: this implements the RFC 3493-style implicit prerelease stuff, I _think_ + ((<) (list (cons '< (exclude-prerelease parsed-version)))) + ((<=) (list (cons '<= parsed-version))) + ((>) (list (cons '> parsed-version))) + ((>=) (list (cons '>= parsed-version))) + ((=) (list (cons '= parsed-version))) + (else (error "unknown sigil" (cons type parsed-version))))))) diff --git a/lang/rust/src/rust.sld b/lang/rust/src/rust.sld new file mode 100644 index 0000000..ec0dcdd --- /dev/null +++ b/lang/rust/src/rust.sld @@ -0,0 +1,140 @@ +(define-library (zilch lang rust) + (import + (scheme base) (scheme write) (scheme process-context) (scheme lazy) + (zilch file) (zilch magic) (zilch nix drv) (zilch nix path) + (zilch nixpkgs) (zilch zexpr) + json + (chicken foreign) (chicken format) + (srfi 4)) + + (export rustc call-rustc) + + (begin + (define rustc (cdr (assoc "out" (nixpkgs "rustc")))) + (define-record-type + (make-rustc-emits asm llvm-bc llvm-ir obj metadata link dep-info mir) + rustc-emits? + (asm rustc-emits-asm set-rustc-emits-asm!) + (llvm-bc rustc-emits-llvm-bc set-rustc-emits-llvm-bc!) + (llvm-ir rustc-emits-llvm-ir set-rustc-emits-llvm-ir!) + (obj rustc-emits-obj set-rustc-emits-obj!) + (metadata rustc-emits-metadata set-rustc-emits-metadata!) + (link rustc-emits-link set-rustc-emits-link!) + (dep-info rustc-emits-dep-info set-rustc-emits-dep-info!) + (mir rustc-emits-mir set-rustc-emits-mir!)) + + (define-record-type + (make-rustc-params cfg check-cfg search-path link crate-type crate-name edition emits externs codegen-flags remap-path-prefix) + rustc-params? + (cfg rustc-params-cfg set-rustc-params-cfg!) + (check-cfg rustc-params-check-cfg set-rustc-params-check-cfg!) + (search-path rustc-params-search-path set-rustc-params-search-path!) + (link rustc-params-link set-rustc-params-link!) + (crate-type rustc-params-crate-type set-rustc-params-crate-type!) + (crate-name rustc-params-crate-name set-rustc-params-crate-name!) + (edition rustc-params-edition set-rustc-params-edition!) + (emits rustc-params-emits set-rustc-params-emits!) + (externs rustc-params-externs set-rustc-params-externs!) + (codegen-flags rustc-params-codegen-flags set-rustc-params-codegen-flags!) + (remap-path-prefix rustc-params-remap-path-prefix set-rustc-params-remap-path-prefix!)) + + (define (rustc-emits-as-list emits tail types) + (define (check-one res name) + (when (and res (boolean? res)) + (set! tail (cons "--emit" (cons (string-append name "=" (make-placeholder name)) tail))) + (set! types (cons name types))) + (when (and res (not (boolean? res))) + (set! tail (cons "--emit" (cons #~,(string-append name "=" #$name) tail))) + (set! types (cons name types)))) + (check-one (rustc-emits-asm emits) "asm") + (check-one (rustc-emits-llvm-bc emits) "llvm-bc") + (check-one (rustc-emits-llvm-ir emits) "llvm-ir") + (check-one (rustc-emits-obj emits) "obj") + (check-one (rustc-emits-metadata emits) "metadata") + (check-one (rustc-emits-link emits) "link") + (check-one (rustc-emits-dep-info emits) "dep-info") + (check-one (rustc-emits-mir emits) "mir") + (values tail types)) + + (define (parse-rustc-emits out items) + (if (eq? items '()) + out + (case (car items) + ((#:asm) (set-rustc-emits-asm! out (cadr items)) (parse-rustc-emits out (cddr items))) + ((#:llvm-bc) (set-rustc-emits-llvm-bc! out (cadr items)) (parse-rustc-emits out (cddr items))) + ((#:llvm-ir) (set-rustc-emits-llvm-ir! out (cadr items)) (parse-rustc-emits out (cddr items))) + ((#:obj) (set-rustc-emits-obj! out (cadr items)) (parse-rustc-emits out (cddr items))) + ((#:metadata) (set-rustc-emits-metadata! out (cadr items)) (parse-rustc-emits out (cddr items))) + ((#:link) (set-rustc-emits-link! out (cadr items)) (parse-rustc-emits out (cddr items))) + ((#:dep-info) (set-rustc-emits-dep-info! out (cadr items)) (parse-rustc-emits out (cddr items))) + ((#:mir) (set-rustc-emits-mir! out (cadr items)) (parse-rustc-emits out (cddr items))) + (else (error "unknown rustc emits param" items))))) + + (define (parse-rustc-params out items) + (if (eq? items '()) + out + (case (car items) + ((#:cfg) (set-rustc-params-cfg! out (cons (cadr items) (rustc-params-cfg out))) (parse-rustc-params out (cddr items))) + ((#:check-cfg) (set-rustc-params-check-cfg! out (cons (cadr items) (rustc-params-check-cfg out))) (parse-rustc-params out (cddr items))) + ((#:search-path) (set-rustc-params-search-path! out (cons (cadr items) (rustc-params-search-path out))) (parse-rustc-params out (cddr items))) + ((#:link) (set-rustc-params-link! out (cons (cadr items) (rustc-params-link out))) (parse-rustc-params out (cddr items))) + ((#:crate-type) (set-rustc-params-crate-type! out (cadr items)) (parse-rustc-params out (cddr items))) + ((#:crate-name) (set-rustc-params-crate-name! out (cadr items)) (parse-rustc-params out (cddr items))) + ((#:edition) (set-rustc-params-edition! out (cadr items)) (parse-rustc-params out (cddr items))) + ((#:emits) (set-rustc-params-emits! out (parse-rustc-emits (make-rustc-emits #f #f #f #f #f #f #f #f) (cadr items))) (parse-rustc-params out (cddr items))) + ((#:externs) (set-rustc-params-externs! out (cons (cadr items) (rustc-params-externs out))) (parse-rustc-params out (cddr items))) + ((#:codegen-flags) (set-rustc-params-codegen-flags! out (cons (cadr items) (rustc-params-codegen-flags out))) (parse-rustc-params out (cddr items))) + ((#:remap-path-prefix) (set-rustc-params-remap-path-prefix! out (cons (cadr items) (rustc-params-remap-path-prefix out))) (parse-rustc-params out (cddr items))) + (else (error "unknown rustc param" (car items)))))) + + (define (call-rustc input env . params) + (call-rustc-internal input env (parse-rustc-params (make-rustc-params '() '() '() '() #f #f #f #f '() '() '()) params))) + + (define (call-rustc-internal input-path env params) + (define args (list input-path)) + (when (rustc-params-cfg params) + (for-each + (lambda (k) (set! args (cons "--cfg" (cons k args)))) (rustc-params-cfg params))) + (when (rustc-params-check-cfg params) + (for-each + (lambda (k) (set! args (cons "--check-cfg" (cons k args)))) (rustc-params-check-cfg params))) + (when (rustc-params-link params) + (for-each + (lambda (k) + (if (not (pair? k)) + (set! args (cons "-l" (cons k args))) + (set! args (cons "-l" (cons #~,(string-append (car k) "=" #$(cdr k)) args))))) + (rustc-params-link params))) + (when (rustc-params-search-path params) + (for-each + (lambda (k) + (if (not (pair? k)) + (set! args (cons "-L" (cons #~,(string-append "all=" #$k) args))) + (set! args (cons "-L" (cons #~,(string-append (car k) "=" #$(cdr k)) args))))) + (rustc-params-search-path params))) + (set! args (cons "--crate-type" (cons (symbol->string (rustc-params-crate-type params)) args))) + (set! args (cons "--crate-name" (cons (rustc-params-crate-name params) args))) + (set! args (cons "--edition" (cons (rustc-params-edition params) args))) + + (define-values (new-args outputs) (rustc-emits-as-list (rustc-params-emits params) args '())) + (set! args new-args) + + (when (rustc-params-externs params) + (for-each + (lambda (k) + (if (pair? k) + (set! args (cons "--extern" (cons #~,(string-append (car k) "=" #$(cdr k)) args))) + (set! args (cons "--extern" (cons k args))))) + (rustc-params-externs params))) + (when (rustc-params-codegen-flags params) + (for-each + (lambda (k) + (set! args (cons "-C" (cons #~,(string-append (car k) "=" #$(cdr k)) args)))) + (rustc-params-codegen-flags params))) + (when (rustc-params-remap-path-prefix params) + (for-each + (lambda (k) + (set! args (cons "--remap-path-prefix" (cons #~,(string-append #$(car k) "=" #$(cdr k)) args)))) + (rustc-params-remap-path-prefix params))) + (store-path-for-ca-drv* (string-append "rustc-" (symbol->string (rustc-params-crate-type params)) "-" (rustc-params-crate-name params)) "x86_64-linux" #~(,(string-append #$rustc "/bin/rustc") . #$args) env outputs)))) + diff --git a/lang/rust/zilch-lang-rust.egg b/lang/rust/zilch-lang-rust.egg new file mode 100644 index 0000000..96cbe8f --- /dev/null +++ b/lang/rust/zilch-lang-rust.egg @@ -0,0 +1,22 @@ +((version "0.0.1") + (synopsis "Nix. Noppes. Nada.") + (author "puck") + (dependencies r7rs json zilch zilch.lang.go srfi-207) + (component-options + (csc-options "-X" "r7rs" "-X" "zilch.zexpr" "-R" "r7rs" "-optimize-level" "3")) + (components + (extension zilch.lang.rust + (source "src/rust.sld")) + (extension zilch.lang.rust.registry + (source "src/registry.sld")) + (extension zilch.lang.rust.cargo + (source "src/cargo.sld") + (component-dependencies zilch.lang.rust zilch.lang.rust.registry zilch.lang.rust.cfg)) + (extension zilch.lang.rust.cfg + (source "src/cfg.sld")) + (extension zilch.lang.rust.build-script + (source "src/build-script.sld") + (component-dependencies zilch.lang.rust)) + (extension zilch.lang.rust.resolver + (source "src/resolver.sld") + (component-dependencies zilch.lang.rust zilch.lang.rust.registry zilch.lang.rust.cargo zilch.lang.rust.build-script)))) diff --git a/shell.nix b/shell.nix index 80f0340..86261b2 100644 --- a/shell.nix +++ b/shell.nix @@ -9,6 +9,7 @@ pkgs.mkShell { buildInputs = [ (pkgs.callPackage ./core {}) (pkgs.callPackage ./lang/go {}) + (pkgs.callPackage ./lang/rust {}) (pkgs.callPackage ./docs/docread {}) (pkgs.callPackage ./cli {}) @@ -26,6 +27,7 @@ pkgs.mkShell { pkgs.nodejs pkgs.bpftrace pkgs.s6 + pkgs.yj pkgs.rlwrap ];