(zilch lang rust): initial commit
This commit is contained in:
parent
d52a1e7796
commit
5380ac9307
12 changed files with 1392 additions and 3 deletions
133
lang/rust/src/build-script.sld
Normal file
133
lang/rust/src/build-script.sld
Normal file
|
|
@ -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
|
||||
<build-script-output>
|
||||
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 <build-script-output>
|
||||
(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 (<build-script-output> entry out)
|
||||
(fprintf out "#<build-script-output changed:~S env-changed:~S flags:~S cfg:~S check-cfg:~S env:~S>"
|
||||
(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))))))
|
||||
|
||||
362
lang/rust/src/cargo.sld
Normal file
362
lang/rust/src/cargo.sld
Normal file
|
|
@ -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
|
||||
<cargo-target> 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
|
||||
|
||||
<cargo-dep-git> make-cargo-dep-git cargo-dep-git?
|
||||
cargo-dep-git-url cargo-dep-git-rev-type cargo-dep-git-rev
|
||||
<cargo-dep-path> make-cargo-dep-path cargo-dep-path? cargo-dep-path-path
|
||||
<cargo-dep-registry> make-cargo-dep-registry cargo-dep-registry? cargo-dep-registry-name
|
||||
|
||||
<cargo-dependency> 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
|
||||
|
||||
<cargo-crate> 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 <cargo-target>
|
||||
(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 (<cargo-target> entry out)
|
||||
(fprintf out "#<cargo-target ~S ~S test:~S doctest:~S bench:~S doc:~S proc-macro:~S harness:~S edition:~S ~S required-features:~S>"
|
||||
(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 <cargo-dep-git>
|
||||
(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 (<cargo-dep-git> entry out)
|
||||
(fprintf out "#<cargo-dep-git ~S ~S ~S>"
|
||||
(cargo-dep-git-url entry)
|
||||
(cargo-dep-git-rev-type entry)
|
||||
(cargo-dep-git-rev entry)))
|
||||
|
||||
(define-record-type <cargo-dep-path>
|
||||
(make-cargo-dep-path path)
|
||||
cargo-dep-path?
|
||||
(path cargo-dep-path-path))
|
||||
|
||||
(define-record-printer (<cargo-dep-path> entry out)
|
||||
(fprintf out "#<cargo-dep-path ~S>"
|
||||
(cargo-dep-path-path entry)))
|
||||
|
||||
(define-record-type <cargo-dep-registry>
|
||||
(make-cargo-dep-registry name)
|
||||
cargo-dep-registry?
|
||||
(name cargo-dep-registry-name))
|
||||
(define-record-printer (<cargo-dep-registry> entry out)
|
||||
(fprintf out "#<cargo-dep-registry ~S>"
|
||||
(cargo-dep-registry-name entry)))
|
||||
|
||||
(define-record-type <cargo-dependency>
|
||||
(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 (<cargo-dependency> entry out)
|
||||
(fprintf out "#<cargo-dependency ~S ~S v:~S default-features:~S features:~S package:~S optional:~S>"
|
||||
(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 <cargo-crate>
|
||||
(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 (<cargo-crate> entry out)
|
||||
(fprintf out "#<cargo-crate ~S ~S edition:~S dependencies:~S features:~S lib-target:~S targets:~S>"
|
||||
(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))))
|
||||
124
lang/rust/src/cfg.sld
Normal file
124
lang/rust/src/cfg.sld
Normal file
|
|
@ -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))))))
|
||||
82
lang/rust/src/registry.sld
Normal file
82
lang/rust/src/registry.sld
Normal file
|
|
@ -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 <lockfile-entry>
|
||||
(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 (<lockfile-entry> entry out)
|
||||
(fprintf out "#<lockfile-entry ~A ~A ~A csum:~A deps:~A>"
|
||||
(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) '())))))
|
||||
493
lang/rust/src/resolver.sld
Normal file
493
lang/rust/src/resolver.sld
Normal file
|
|
@ -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
|
||||
<resolver> make-resolver resolver? resolver-locked-dependencies resolver-selected-dependencies
|
||||
<resolved-package-build-data> 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
|
||||
|
||||
<resolved-package> 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 <resolver>
|
||||
; 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 <resolved-package-build-data>
|
||||
(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 <resolved-package>
|
||||
(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 <resolved-package>, 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 <resolved-package>. 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 <cargo-dependency>, returning the <resolved-package>.
|
||||
(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 (version<? (caar l) (car best-version))) best-version (car l))))
|
||||
(else (find-matching-version (cdr l) best-version))))
|
||||
(define matching-version (find-matching-version existing-mapping #f))
|
||||
(if matching-version
|
||||
(cdr matching-version)
|
||||
(let* ((best-version (mapping-fold/reverse (lambda (k v acc) (if (or acc (not (matches-requirements (car v) requirements))) acc (car v))) #f available-versions))
|
||||
(resolved (resolver-download resolver package-name best-version)))
|
||||
(when (cargo-dependency-default-features dep)
|
||||
(resolver-activate-features resolver resolved '("default")))
|
||||
(when (cargo-dependency-features dep)
|
||||
(resolver-activate-features resolver resolved (cargo-dependency-features dep)))
|
||||
resolved)))
|
||||
|
||||
(define (resolver-print-pkg resolver pkg)
|
||||
(printf " - version: ~S\n" (resolved-package-version pkg))
|
||||
(printf " features: ~S\n" (resolved-package-enabled-features pkg))
|
||||
(printf " dependencies:\n")
|
||||
(for-each
|
||||
(lambda (dep)
|
||||
(define found-dep (mapping-ref/default (resolved-package-dependencies pkg) (cargo-dependency-name dep) #f))
|
||||
(printf " - ~A: ~A ~A" (cargo-dependency-name dep) (cargo-dependency-package dep) (cargo-dependency-version dep))
|
||||
(if found-dep
|
||||
(printf " (activated! ~A)\n" (resolved-package-version found-dep))
|
||||
(printf "\n")))
|
||||
(resolved-package-target-dependencies pkg)))
|
||||
|
||||
(define (resolver-print resolver)
|
||||
(mapping-for-each
|
||||
(lambda (k v)
|
||||
(printf "Package ~S:\n" k)
|
||||
(for-each
|
||||
(lambda (pair)
|
||||
(resolver-print-pkg resolver (cdr pair)))
|
||||
v))
|
||||
(resolver-selected-dependencies resolver)))
|
||||
|
||||
(define (process-cargo-with-lockfile vfs cargo-file parsed-lockfile activated-features)
|
||||
(define locked-dependencies (mapping (make-default-comparator)))
|
||||
(for-each
|
||||
(lambda (item)
|
||||
(define name (lockfile-entry-name item))
|
||||
(define inner (mapping-ref locked-dependencies name (lambda () (mapping (make-default-comparator)))))
|
||||
(set! locked-dependencies
|
||||
(mapping-set! locked-dependencies name
|
||||
(mapping-set! inner
|
||||
(lockfile-entry-version item)
|
||||
(cons (parse-version (lockfile-entry-version item)) (cons item (delay (fetch-and-unpack-crate item))))))))
|
||||
parsed-lockfile)
|
||||
|
||||
(define resolver (make-resolver locked-dependencies (mapping (make-default-comparator))))
|
||||
(define pkg (resolver-register resolver vfs cargo-file))
|
||||
(resolver-activate-features resolver pkg activated-features)
|
||||
(resolver-print resolver)
|
||||
pkg)
|
||||
|
||||
(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 (build-package resolved)
|
||||
; Info we need to collect:
|
||||
; - enabled features
|
||||
; - dependencies
|
||||
; - exact file dependencies (optional!)
|
||||
; ..let's just give it a try, I guess?
|
||||
; emits: (dep-info: #t)
|
||||
(define crate-name (cargo-target-name (resolved-package-cargo-target resolved)))
|
||||
(define crate-version (version-str (resolved-package-version resolved)))
|
||||
(define crate-root (if (vfs? (resolved-package-fs resolved)) (vfs-to-store (resolved-package-fs resolved)) (resolved-package-fs resolved)))
|
||||
(define crate-type (cargo-target-crate-type (resolved-package-cargo-target resolved)))
|
||||
(define buildscript-metadata '())
|
||||
(define dependency-metadata '())
|
||||
(define bin-flags '())
|
||||
|
||||
(define params `(#:crate-type ,crate-type
|
||||
#:remap-path-prefix (,crate-root . ,(string-append crate-name "-" (version-str (resolved-package-version resolved))))
|
||||
#:codegen-flags ("metadata" . ,(string-append "zilch version=" (version-str (resolved-package-version resolved))))
|
||||
#:codegen-flags ("extra-filename" . ,(string-append "v" crate-version))
|
||||
#:edition ,(cargo-target-edition (resolved-package-cargo-target resolved))
|
||||
#:crate-name ,crate-name))
|
||||
(when (eq? crate-type 'proc-macro)
|
||||
(set! params `(externs: "proc_macro" . ,params)))
|
||||
(for-each
|
||||
(lambda (feature)
|
||||
(set! params (cons #:cfg (cons (string-append "feature=\"" feature "\"") params))))
|
||||
(resolved-package-enabled-features resolved))
|
||||
|
||||
(define rustc-env
|
||||
#~(
|
||||
; ("CARGO" . "")
|
||||
("CARGO_MANIFEST_DIR" . "")
|
||||
("CARGO_PKG_VERSION" . ,(version-str (resolved-package-version resolved)))
|
||||
("CARGO_PKG_VERSION_MAJOR" . ,(number->string (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<? ver (cdar req)))
|
||||
((<=) (or (version=? ver (cdar req)) (version<? ver (cdar req))))
|
||||
((>) (version<? (cdar req) ver))
|
||||
((>=) (or (version=? ver (cdar req)) (version<? (cdar req) ver)))
|
||||
((=) (version=? ver (cdar req))))
|
||||
(matches-requirements ver (cdr req)))))
|
||||
|
||||
(define (parse-version-requirement str)
|
||||
(set! str (string-drop-while str char-whitespace?))
|
||||
(set! str (string-drop-while-right str char-whitespace?))
|
||||
(define type '^)
|
||||
(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 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)))))))
|
||||
140
lang/rust/src/rust.sld
Normal file
140
lang/rust/src/rust.sld
Normal file
|
|
@ -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 <rustc-emits>
|
||||
(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 <rustc-params>
|
||||
(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))))
|
||||
|
||||
Loading…
Add table
Add a link
Reference in a new issue