zilch/lang/rust/src/cargo.sld

(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 rust cfg)
  (zilch 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 cargo-crate-check-cfg-lint

  <cargo-workspace> make-cargo-workspace cargo-workspace?
  cargo-workspace-members cargo-workspace-exclude cargo-workspace-dependencies
  cargo-workspace-version cargo-workspace-edition

  cfg-values

  parse-cargo-toml)

 (begin
   (define linker (delay (let ((v (cdr (assoc "out" (nixpkgs "gcc"))))) #~,(string-append #$v "/bin/cc"))))
   (define yj-path (foreign-value "YJ_PATH" nonnull-c-string))

   ;; 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-path '("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 workspace dependencies build-dependencies features lib-target build-script targets links check-cfg-lint)
     cargo-crate?
     (name cargo-crate-name)
     (version cargo-crate-version)
     (edition cargo-crate-edition)
     (workspace cargo-crate-workspace)
     (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)
     (check-cfg-lint cargo-crate-check-cfg-lint))

   (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)))

   (define-record-type <cargo-workspace>
     (make-cargo-workspace members exclude dependencies edition version check-cfg-lint)
     cargo-workspace?
     (members cargo-workspace-members)
     (exclude cargo-workspace-exclude)
     (dependencies cargo-workspace-dependencies set-cargo-workspace-dependencies!)
     (edition cargo-workspace-edition)
     (version cargo-workspace-version)
     (check-cfg-lint cargo-workspace-check-cfg-lint))

   (define-record-printer (<cargo-workspace> entry out)
     (fprintf out "#<cargo-workspace members:~S exclude:~S deps:~S>"
       (cargo-workspace-members entry)
       (cargo-workspace-exclude entry)
       (cargo-workspace-dependencies entry)))
  
   (foreign-declare "#include \"cfgfetch_source.h\"")
   (define cfgfetch-bin
     (cdar
       (call-rustc
         (zfile (foreign-value "cfgfetch_source" nonnull-c-string)) '()
         #:codegen-flags (cons "linker" (force linker))
         #:crate-type 'bin
         #:crate-name "cfgfetch"
         #:edition "2021"
         #:emits '(#:link #t))))

   (define cfg-target "x86_64-unknown-linux-gnu")
   (define (read-cfg-value port rest)
     (define line (read-line port))
     (if (eof-object? line)
       rest
       (let* ((line (cfg-parse line)))
         (read-cfg-value port (cons (cdr line) rest)))))

   (define cfg-values
     (let ((vals (cdar (store-path-for-ca-drv* "cfg-values" "x86_64-linux" #~(#$cfgfetch-bin) #~(("rustc" . ,(string-append #$rustc "/bin/rustc"))) '("out")))))
       (call-with-port (store-path-open vals) (lambda (p) (read-cfg-value p '())))))

   (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 (find-dependency-in-list l dep-name)
     (cond
       ((null? l) #f)
       ((string=? dep-name (cargo-dependency-name (car l))) (car l))
       (else (find-dependency-in-list (cdr l) dep-name))))

   (define (cargo-dependency-from-toml name object workspace for-workspace)
     (define object-internals (vector->list object))
     (define version (and-cdr (assoc "version" object-internals)))
     (define default-features (and-cdr-default (or (assoc "default-features" object-internals) (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 is-workspace (and-cdr (assoc "workspace" object-internals)))
     (when (and is-workspace (not workspace))
       (error "Dependency uses workspace=true, whilst not a workspace" (cons name object-internals)))

     (define workspace-dep
       (and is-workspace (find-dependency-in-list (cargo-workspace-dependencies workspace) name)))
     (when (and is-workspace (not workspace-dep))
       (error "Dependency could not be found in workspace" name))
     (when workspace-dep
       (set! version (cargo-dependency-version workspace-dep))
       (set! default-features (cargo-dependency-default-features workspace-dep))
       (for-each
         (lambda (feature) (unless (member feature pkg-features)) (set! pkg-features (cons feature pkg-features)))
         (cargo-dependency-features workspace-dep))
       (set! package (cargo-dependency-package workspace-dep)))

     (define origin (cond
                      (workspace-dep (cargo-dependency-origin workspace-dep))
                      (path (make-cargo-dep-path (if for-workspace (cons 'workspace 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 vfs object crate-name base-type base-edition)
     (define object-internals (vector->list object))

     (define (multifile-if-available base name)
       (if (vfs-file-ref vfs (string-append base name) "main.rs")
          (string-append base name "/main.rs")
          (string-append base name ".rs")))

     (unless (or (eq? base-type 'lib) (assoc "name" object-internals)) (error "cargo target has no name"))
     (define name (cratify-name (or (and-cdr (assoc "name" object-internals)) crate-name)))
     (define path (or (and-cdr (assoc "path" object-internals))
                      (case base-type
                        ((lib) "src/lib.rs")
                        ;; TODO(puck): multi-file
                        ((bin) (multifile-if-available "src/bin/" name))
                        ((example) (multifile-if-available "examples/" name))
                        ((test) (multifile-if-available "tests/" name))
                        ((benchmark) (multifile-if-available "benches/" name)))))
     (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 build-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)
    (for-each (lambda (name) (set! needs-implicit-dependency (mapping-set! needs-implicit-dependency name #t))) build-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-package vfs internals workspace)
     (unless vfs (error "no vfs"))
     (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"))

     (define lints (vector->list (or (and-cdr (assoc "lints" internals)) #())))
     (define lints-rust (vector->list (or (and-cdr (assoc "rust" lints)) #())))
     (define lints-rust-unexpected-cfgs (vector->list (or (and-cdr (assoc "unexpected_cfgs" lints-rust)) #())))
     (define check-cfg (or (and-cdr (assoc "check-cfg" lints-rust-unexpected-cfgs)) '()))

     (when (and (vector? package-edition) (and-cdr (assoc "workspace" (vector->list package-edition))))
       (unless workspace (error "Package used edition.workspace = true, but no workspace provided" package-name))
       (set! package-edition (cargo-workspace-edition workspace)))

     (when (and (vector? package-version) (and-cdr (assoc "workspace" (vector->list package-version))))
       (unless workspace (error "Package used version.workspace = true, but no workspace provided" package-name))
       (set! package-version (cargo-workspace-version workspace)))

     (define lib-target #f)
     (when (or (assoc "lib" internals) (vfs-file-ref vfs "src" "lib.rs"))
       (set! lib-target (cargo-target-from-toml vfs (or (and-cdr (assoc "lib" internals)) #()) package-name 'lib package-edition)))
       
     (define other-targets '())
     (cond
      ((assoc "bin" internals)
       (for-each
        (lambda (bindata)
         (set! other-targets (cons (cargo-target-from-toml vfs bindata package-name 'bin package-edition) other-targets)))
        (cdr (assoc "bin" internals))))
      ((vfs-file-ref vfs "src" "main.rs")
       (set! other-targets (cons (cargo-target-from-toml vfs (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)))
     (when (vfs-file-ref vfs "" "build.rs")
       (set! build-file-path "build.rs"))
     (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 package-edition 'bin '("default"))))

     (define dependencies
       (map
         (lambda (kv)
           (cargo-dependency-from-toml (car kv) (if (string? (cdr kv)) (vector (cons "version" (cdr kv))) (cdr kv)) workspace #f))
         (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)) workspace #f))
         (vector->list (or (and-cdr (or (assoc "build-dependencies" internals) (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)) workspace #f))
                 (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) (map cargo-dependency-name build-dependencies)))
     (make-cargo-crate package-name package-version package-edition workspace dependencies build-dependencies own-features lib-target build-script-target other-targets package-links (append check-cfg (if workspace (cargo-workspace-check-cfg-lint workspace) '()))))

   (define (parse-cargo-workspace internals)
     (define workspace (vector->list (cdr (assoc "workspace" internals))))
     (define workspace-members (or (and-cdr (assoc "members" workspace)) '()))
     (define workspace-exclude (or (and-cdr (assoc "exclude" workspace)) '()))

     (define lints (vector->list (or (and-cdr (assoc "lints" internals)) #())))
     (define lints-rust (vector->list (or (and-cdr (assoc "rust" lints)) #())))
     (define lints-rust-unexpected-cfgs (vector->list (or (and-cdr (assoc "unexpected_cfgs" lints-rust)) #())))
     (define check-cfg (or (and-cdr (assoc "check-cfg" lints-rust-unexpected-cfgs)) '()))

     (define package (vector->list (or (and-cdr (assoc "package" workspace)) #())))
     (define package-edition (and-cdr (assoc "edition" package)))
     (define package-version (and-cdr (assoc "version" package)))

     (define workspace-record (make-cargo-workspace workspace-members workspace-exclude #f package-edition package-version check-cfg))
     (define dependencies
       (map
         (lambda (kv)
           (cargo-dependency-from-toml (car kv) (if (string? (cdr kv)) (vector (cons "version" (cdr kv))) (cdr kv)) #f #t))
         (vector->list (or (and-cdr (assoc "dependencies" workspace)) #()))))
     (set-cargo-workspace-dependencies! workspace-record dependencies)
     workspace-record)

   (define (parse-cargo-toml vfs cargo-file workspace)
     (define internals (vector->list (parse-toml cargo-file)))
     (define crate #f)
     (when (assoc "workspace" internals)
       (when workspace
         (error "Crate already is in a workspace." cargo-file))
       (set! workspace (parse-cargo-workspace internals)))
     (when (assoc "package" internals)
       (set! crate (parse-cargo-package vfs internals workspace)))
     (values crate workspace))))