681 lines
37 KiB
Scheme
681 lines
37 KiB
Scheme
(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 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-pending-features
|
|
resolved-package-dependencies
|
|
resolved-package-crate 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 process-many-with-lockfile
|
|
build-package)
|
|
|
|
(begin
|
|
(define gcc (delay (cdr (assoc "out" (nixpkgs "gcc")))))
|
|
(define linker (delay #~,(string-append #$(force gcc) "/bin/cc")))
|
|
|
|
(foreign-declare "#include \"false_source.h\"")
|
|
(define cargo-stub
|
|
(delay
|
|
(cdar
|
|
(call-rustc
|
|
(zfile (foreign-value "false_source" nonnull-c-string)) '()
|
|
#:codegen-flags (cons "linker" (force linker))
|
|
#:crate-type 'bin
|
|
#:crate-name "false"
|
|
#:edition "2021"
|
|
#:emits '(#:link #t)))))
|
|
|
|
; 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)(?)
|
|
; pending-features is a mapping of (package-name . version) to a list of features
|
|
(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 build-script-out)
|
|
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)
|
|
(build-script-out resolved-package-build-data-build-script-out))
|
|
|
|
(define-record-type <resolved-package>
|
|
(make-resolved-package name version fs cargo-target target-dependencies crate enabled-features pending-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!)
|
|
(pending-features resolved-package-pending-features set-resolved-package-pending-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)
|
|
(unless version
|
|
(error "Resolver wanted non-versioned download" name))
|
|
(define dir (force (cddr (mapping-ref (mapping-ref (resolver-locked-dependencies resolver) name) (version-str version)))))
|
|
(define vfs (vfs-from-store dir))
|
|
(resolver-process resolver name vfs #f))
|
|
|
|
(define (resolver-process resolver name vfs workspace)
|
|
(define-values (parsed-cargo parsed-workspace) (parse-cargo-toml vfs (call-with-port (store-path-open (vfs-file-ref vfs "" "Cargo.toml")) (lambda (p) (read-string 99999999 p))) workspace))
|
|
(define version (parse-version (cargo-crate-version parsed-cargo)))
|
|
(unless (cargo-crate-lib-target parsed-cargo)
|
|
(error "Crate does not have valid [lib] target" (list name)))
|
|
|
|
(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)) (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)) (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)))
|
|
(let ((pending-features (mapping-ref/default (resolved-package-pending-features pkg) name #f)))
|
|
(when pending-features
|
|
(set-resolved-package-pending-features! pkg (mapping-delete! (resolved-package-pending-features pkg) name))
|
|
(resolver-activate-features resolver resolved-dep pending-features))))
|
|
|
|
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)
|
|
(define target-package (car activation))
|
|
(define must-activate (cadr activation))
|
|
(define target-feature (cddr activation))
|
|
|
|
(define target-dependency (if target-package (resolver-resolve-resolved-package resolver resolved target-package must-activate) resolved))
|
|
;; NOTE: this is undocumented behavior by cargo
|
|
; if a feature is enabled that enables an optional package, a feature with that same name gets enabled.
|
|
; this is not entirely identical in behavior (TODO(puck): this is too wide a net) but it'll do, roughly.
|
|
(when (and target-dependency target-package) (resolver-activate-features resolver resolved (list target-package)))
|
|
(cond
|
|
((and target-feature target-dependency) (resolver-activate-features resolver target-dependency (list target-feature)))
|
|
; ((and (not target-feature) target-package target-dependency))) ; noop but activated
|
|
((and target-feature (not target-dependency))
|
|
(set-resolved-package-pending-features! resolved
|
|
(mapping-update!/default (resolved-package-pending-features resolved)
|
|
target-package
|
|
(lambda (lst) (if (member target-feature lst) lst (cons target-feature lst)))
|
|
'()))))
|
|
(define build-script (resolved-package-build-script resolved))
|
|
(when build-script
|
|
(let ((target-dependency-build (and target-package (resolver-resolve-resolved-package resolver build-script target-package must-activate))))
|
|
(when (and build-script target-dependency-build target-package) (resolver-activate-features resolver resolved (list target-package)))
|
|
(cond
|
|
((and target-feature target-dependency-build) (resolver-activate-features resolver target-dependency-build (list target-feature)))
|
|
((and target-feature (not target-dependency-build))
|
|
(set-resolved-package-pending-features! build-script
|
|
(mapping-update!/default (resolved-package-pending-features build-script)
|
|
target-package
|
|
(lambda (lst) (if (member target-feature lst) lst (cons target-feature lst)))
|
|
'())))))))
|
|
(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 delayed)
|
|
(define target (cargo-crate-lib-target crate))
|
|
(cond
|
|
((target)
|
|
(list (resolver-register-target resolver vfs crate target #f delayed)))
|
|
((null? (cargo-crate-targets crate))
|
|
(error "Crate has _zero_ targets" crate))
|
|
(else
|
|
(map (lambda (target) (resolver-register-target resolver vfs crate target #f delayed)) (cargo-crate-targets crate)))))
|
|
|
|
;; Register a non-registry crate+vfs with the resolver.
|
|
(define (resolver-register-target resolver vfs crate target extra-dependencies delayed)
|
|
(define build-script #f)
|
|
(unless extra-dependencies
|
|
(set! extra-dependencies (mapping (make-default-comparator))))
|
|
(define version (parse-version (cargo-crate-version crate)))
|
|
(when (cargo-crate-build-script crate)
|
|
(set! build-script (make-resolved-package (string-append (cargo-target-name target) "_build") version vfs (cargo-crate-build-script crate) (cargo-crate-build-dependencies crate) crate '() (mapping (make-default-comparator)) (mapping (make-default-comparator)) #f #f))
|
|
(unless delayed (resolver-resolve-nonoptional resolver build-script)))
|
|
(define pkg (make-resolved-package (cargo-target-name target) version vfs target (cargo-crate-dependencies crate) crate '() (mapping (make-default-comparator)) extra-dependencies #f build-script))
|
|
(define existing-mapping (mapping-ref/default (resolver-selected-dependencies resolver) (cargo-crate-name crate) '()))
|
|
(unless (equal? 'bin (cargo-target-crate-type target))
|
|
(set-resolver-selected-dependencies! resolver (mapping-set (resolver-selected-dependencies resolver) (cargo-crate-name crate) (cons (cons (parse-version (cargo-crate-version crate)) pkg) existing-mapping))))
|
|
(unless delayed
|
|
(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 (if (cargo-dependency-version dep) (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/default (resolver-locked-dependencies resolver) package-name #f))
|
|
(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))
|
|
(unless (or matching-version available-versions)
|
|
(when (cargo-dep-path? (cargo-dependency-origin dep))
|
|
(error "unknown path dependency" dep))
|
|
(error (sprintf "Resolving ~S: could not find matching dep for reqs ~S in ~S\n" dep requirements existing-mapping)))
|
|
(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)
|
|
(printf "Package ~S build scripts:\n" k)
|
|
(for-each
|
|
(lambda (pair)
|
|
(when (resolved-package-build-script (cdr pair)) (resolver-print-pkg resolver (resolved-package-build-script (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 pkgs (resolver-register resolver vfs cargo-file #f))
|
|
(for-each
|
|
(lambda (pkg)
|
|
(resolver-activate-features resolver pkg activated-features))
|
|
pkgs)
|
|
pkgs)
|
|
|
|
(define (process-many-with-lockfile vfs-cargo-map parsed-lockfile)
|
|
(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)))))
|
|
(when (lockfile-entry-source item)
|
|
(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 pkgs '())
|
|
; Resolve each target inside the primary crates.
|
|
; Each crate may have any amount of targets; lib targets here are treated
|
|
; slightly specially as they are the ones used to link against other crates.
|
|
(for-each
|
|
(lambda (crate-and-vfs)
|
|
(define crate (car crate-and-vfs))
|
|
(define vfs (cdr crate-and-vfs))
|
|
(define lib-crate #f)
|
|
(when (cargo-crate-lib-target crate)
|
|
(set! lib-crate (resolver-register-target resolver vfs crate (cargo-crate-lib-target crate) #f #t))
|
|
(set! pkgs (cons lib-crate pkgs)))
|
|
(for-each
|
|
(lambda (target)
|
|
(when (equal? 'bin (cargo-target-crate-type target))
|
|
; A binary crate may refer to its lib crate by that name.
|
|
; Pass an override for dependencies if that is the case.
|
|
(set! pkgs (cons (resolver-register-target resolver vfs crate target
|
|
(and (cargo-crate-lib-target crate) (mapping (make-default-comparator) (cargo-target-name (cargo-crate-lib-target crate)) lib-crate))
|
|
#t) pkgs))))
|
|
(cargo-crate-targets crate)))
|
|
vfs-cargo-map)
|
|
|
|
; Resolve all non-optional dependencies of the targets we've accepted.
|
|
(for-each (lambda (p) (resolver-resolve-nonoptional resolver p) (when (resolved-package-build-script p) (resolver-resolve-nonoptional resolver (resolved-package-build-script p)))) pkgs)
|
|
|
|
; Enable default features on all binary targets. This hopefully resolves into a set of valid features being set on the full project.
|
|
(for-each (lambda (p) (when (eq? (cargo-target-crate-type (resolved-package-cargo-target p)) 'bin) (resolver-activate-features resolver p '("default")))) pkgs)
|
|
|
|
; Print our resolved package set.
|
|
(resolver-print resolver)
|
|
pkgs)
|
|
|
|
(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 (rewrite-env envs)
|
|
(define final-env (mapping (make-default-comparator)))
|
|
(for-each
|
|
(lambda (vars)
|
|
(for-each
|
|
(lambda (env-block)
|
|
(define value (mapping-ref/default final-env (car env-block) #f))
|
|
(if value
|
|
(set! value (string-append (cdr env-block) ":" value))
|
|
(set! value (cdr env-block)))
|
|
(set! final-env (mapping-set! final-env (car env-block) value)))
|
|
vars))
|
|
(reverse envs))
|
|
(mapping-map->list (lambda (k v) (cons k v)) final-env))
|
|
|
|
(define (build-package resolved build-script-env-overrides compiler-env-overrides)
|
|
; 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 (vfs-to-store (resolved-package-fs resolved)))
|
|
(define crate-type (cargo-target-crate-type (resolved-package-cargo-target resolved)))
|
|
|
|
; TODO(puck): workaround for multi-crate-type targets.
|
|
; These should probably be translated into distinct targets?
|
|
(when (list? crate-type)
|
|
(set! crate-type 'rlib))
|
|
(define buildscript-metadata '())
|
|
(define buildscript-out #f)
|
|
(define crate-links '())
|
|
(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" . #$(force cargo-stub))
|
|
("CARGO_MANIFEST_DIR" . #$crate-root)
|
|
,@(if (cargo-crate-links (resolved-package-crate resolved)) (list (cons "CARGO_MANIFEST_LINKS" (cargo-crate-links (resolved-package-crate resolved)))) '())
|
|
("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)
|
|
#$@(compiler-env-overrides (cargo-crate-name (resolved-package-crate resolved)))))
|
|
; CARGO_BIN_NAME, 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)))
|
|
|
|
(define (make-cfg-values-env l out)
|
|
(cond
|
|
((pair? l)
|
|
(let* ((env-name (string-map upcase-underscore (string-append "CARGO_CFG_" (caar l))))
|
|
(existing (assoc env-name out)))
|
|
(when (and existing (cdar l))
|
|
(set-cdr! existing (string-append (cdr existing) "," (cdar l))))
|
|
(if existing
|
|
(make-cfg-values-env (cdr l) out)
|
|
(make-cfg-values-env (cdr l) (cons (cons env-name (or (cdar l) "")) out)))))
|
|
(else out)))
|
|
|
|
(define build-script-envs #f)
|
|
(define seen-crates '())
|
|
(define (transitively-check-package pkg)
|
|
(define name (cargo-crate-name (resolved-package-crate pkg)))
|
|
(unless (member name seen-crates)
|
|
(set! seen-crates (cons name seen-crates))
|
|
(let ((env-override (build-script-env-overrides name #t)))
|
|
(when env-override
|
|
(set! build-script-envs (cons env-override build-script-envs))))
|
|
(mapping-for-each (lambda (k v) (transitively-check-package v)) (resolved-package-dependencies pkg))))
|
|
|
|
(when (resolved-package-build-script resolved)
|
|
;; "build" here is a misnomer; it's handling the .drv:s.
|
|
(unless (resolved-package-build-data (resolved-package-build-script resolved))
|
|
(build-package (resolved-package-build-script resolved) build-script-env-overrides compiler-env-overrides))
|
|
|
|
;; Process the transitive build dependencies for the build script, and set env overrides
|
|
;; based on them.
|
|
(set! build-script-envs (list (build-script-env-overrides (cargo-crate-name (resolved-package-crate resolved)) #f)))
|
|
(mapping-for-each
|
|
(lambda (key value)
|
|
(transitively-check-package value))
|
|
(resolved-package-dependencies (resolved-package-build-script resolved)))
|
|
|
|
; For each package dependency, check if it has "links" metadata.
|
|
; Crate that immediately depend on other crates that have this metadata have
|
|
; the cargo::metadata pairs passed to the build script.
|
|
(mapping-for-each
|
|
(lambda (key value)
|
|
(unless (resolved-package-build-data value)
|
|
(build-package value build-script-env-overrides compiler-env-overrides))
|
|
(when (cargo-crate-links (resolved-package-crate value))
|
|
; Track (link-name . build-data) for each crate in immediate dependencies that applies
|
|
(set! crate-links (cons (cons (cargo-crate-links (resolved-package-crate value)) (resolved-package-build-data value)) crate-links))))
|
|
(resolved-package-dependencies resolved))
|
|
|
|
; Collect the necessary bits, and build the build script.
|
|
(let*-values
|
|
(((build-script) (cdr (resolved-package-build-data-rlib (resolved-package-build-data (resolved-package-build-script resolved)))))
|
|
((rewritten-features) (map (lambda (feature) (cons (string-map upcase-underscore (string-append "CARGO_FEATURE_" feature)) "1")) (resolved-package-enabled-features resolved)))
|
|
((runner-outdir runner-outpath)
|
|
(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")
|
|
("_zilch_links" . ,(string-join #$(map (lambda (kv) #~,(string-append #$(resolved-package-build-data-build-script-out (cdr kv)) ":" (car kv))) crate-links) "!"))
|
|
,@(make-cfg-values-env cfg-values '())
|
|
,@dependency-metadata
|
|
,@rewritten-features
|
|
,@(rewrite-env #$build-script-envs)
|
|
; TODO: OUT_DIR, NUM_JOBS, OPT_LEVEL/DEBUG/PROFILE
|
|
; RUSTC/RUSTDOC?, RUSTC_LINKER? and CARGO_ENCODED_RUSTFLAGS
|
|
. #$rustc-env))))
|
|
; Pass the buildscript-out data to the next crate.
|
|
(set! buildscript-out runner-outpath)
|
|
|
|
; Pass cargo::rustc-cfg and cargo::rustc-check-cfg to the crate this build script belongs to.
|
|
; Also set OUT_DIR for include! and include_str! reasons.
|
|
(let ((old-rustc-env rustc-env))
|
|
(set! rustc-env #~(("OUT_DIR" . #$runner-outdir) ("_zilch_proc" . #$runner-outpath) . #$old-rustc-env)))))
|
|
|
|
(define params-meta params)
|
|
(define transitive-dependencies '())
|
|
(mapping-for-each
|
|
(lambda (key value)
|
|
(unless (resolved-package-build-data value)
|
|
(build-package value build-script-env-overrides compiler-env-overrides))
|
|
(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)))
|
|
(define name (cratify-name key))
|
|
; TODO(puck): what _is_ the logic here?
|
|
(when (string=? key (cargo-crate-name (resolved-package-crate value)))
|
|
(set! name (cratify-name (cargo-target-name (resolved-package-cargo-target value)))))
|
|
(set! params-meta
|
|
`(#:externs (,name . ,(cdr meta-or-rlib)) . ,params-meta))
|
|
(set! params
|
|
`(#:externs (,name . ,(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 all-crate-features '())
|
|
(for-each
|
|
(lambda (feat)
|
|
(set! all-crate-features
|
|
(cons
|
|
(string-append "\"" (car feat) "\"")
|
|
all-crate-features)))
|
|
(cargo-crate-features (resolved-package-crate resolved)))
|
|
|
|
(set! params `(check-cfg: ,(string-append "cfg(feature, values(" (string-join all-crate-features ",") "))")
|
|
check-cfg: "cfg(docsrs,test)"
|
|
cap-lints: "warn"
|
|
. ,params))
|
|
|
|
(for-each (lambda (check) (set! params `(check-cfg: ,check . ,params))) (cargo-crate-check-cfg-lint (resolved-package-crate resolved)))
|
|
|
|
(define inherited-build-script-out '())
|
|
(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))
|
|
(when (resolved-package-build-data-build-script-out (resolved-package-build-data dep))
|
|
(set! inherited-build-script-out (cons (resolved-package-build-data-build-script-out (resolved-package-build-data dep)) inherited-build-script-out))))
|
|
transitive-dependencies)
|
|
|
|
(unless (eq? crate-type 'rlib)
|
|
(set! params `(codegen-flags: ("linker" . ,(force linker)) . ,params)))
|
|
|
|
(define path #~,(string-append #$(vfs-to-store (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 (eq? crate-type 'bin)
|
|
(set! rlib-name crate-name))
|
|
|
|
; (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 (("_zilch_inherit" . ,#~,(string-join #$inherited-build-script-out " ")) . ,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))
|
|
|
|
(set-resolved-package-build-data! resolved (make-resolved-package-build-data dep-info metadata rlib transitive-dependencies buildscript-metadata bin-flags buildscript-out))
|
|
rlib-file)
|
|
|
|
(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 '< (first-incompatible parsed-version)))) ; TODO(puck): is this correct? how *should* "<= 3" be parsed.
|
|
((>) (list (cons '> parsed-version)))
|
|
((>=) (list (cons '>= parsed-version)))
|
|
((=) (list (cons '= parsed-version)))
|
|
(else (error "unknown sigil" (cons type parsed-version)))))))
|