362 lines
17 KiB
Scheme
362 lines
17 KiB
Scheme
(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))))
|