zilch/lang/rust/src/rust.sld

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