diff --git a/core/src/magic.sld b/core/src/magic.sld index f25f8a3..30e995d 100644 --- a/core/src/magic.sld +++ b/core/src/magic.sld @@ -3,7 +3,7 @@ ;; A `` unquotes in `zexp`s as its store path. (define-library (zilch magic) (import - (scheme base) (scheme file) + (scheme base) (scheme file) (scheme lazy) (zilch lib hash) (zilch nix daemon) (zilch nix drv) (zilch nix path) (zilch nix hash) (zilch planner step) @@ -21,6 +21,7 @@ store-path-for-text store-path-for-fod store-path-for-drv store-path-for-impure-drv store-path-for-ca-drv store-path-for-ca-drv* store-path-realised store-path-open + store-path-devirtualise drv-resolve-ca @@ -241,9 +242,7 @@ (replace-placeholder placeholder replacement (+ index (string-length replacement)))) (> start-index 0))) - (define context-to-build '()) - (define drv-output-map #f) - (define placeholders-to-build '()) + (define added-sources '()) (for-each (lambda (drv-and-outputs) @@ -254,11 +253,12 @@ (lambda (output) (define placeholder (derivation-output-path (cdr (assoc output (derivation-outputs drv))))) (define new-path (cdr (assoc output ca-drv))) - (replace-placeholder placeholder new-path 0)) + (when (replace-placeholder placeholder new-path 0) + (set! added-sources (cons new-path added-sources)))) (cdr drv-and-outputs)))) drv-context) - path) + (values path added-sources)) (define (zexp-ctx-has-placeholder drv-context) (if (null? drv-context) @@ -498,22 +498,45 @@ (pending-item-resolved-paths (rewrite-ca-stack drv)) #f)) - (define (store-path-realised path) - (define ctx (zexp-unwrap (zexp (zexp-unquote path)))) + (define (devirtualise-inner zexpr) + (define ctx (zexp-unwrap (zexp (zexp-unquote zexpr)))) (define val (zexp-evaluation-value ctx)) - (define to-build (list)) + (define drvs '()) + (define srcs (zexp-evaluation-srcs ctx)) (for-each (lambda (drv-and-outputs) (unless (drv-is-ca (car drv-and-outputs)) - (for-each - (lambda (o) - (set! to-build (cons (string-append (derivation-path (car drv-and-outputs)) "!" o) to-build))) - (cdr drv-and-outputs)))) + (set! drvs (cons drv-and-outputs drvs)))) (zexp-evaluation-drvs ctx)) (if (string? val) - (set! val (resolve-upstream-output-placeholders val (zexp-evaluation-drvs ctx))) + (let-values (((new-val new-srcs) (resolve-upstream-output-placeholders val (zexp-evaluation-drvs ctx)))) + (set! val new-val) + (set! srcs (append new-srcs srcs))) (when (zexp-ctx-has-placeholder (zexp-evaluation-drvs ctx)) - (error "store-path-realised: expression has dependencies on placeholder context, but isn't a string" (list path val)))) + (error "store-path-devirtualise: expression has dependencies on placeholder context, but isn't a string" (list zexpr val)))) + (list val drvs srcs)) + + (define (store-path-devirtualise zexpr) + (define inner (delay (devirtualise-inner zexpr))) + (make-zexp + (lambda () + (define processed (force inner)) + (zexp-context-register-items (list-ref processed 1) (list-ref processed 2)) + (car processed)) + (lambda (out) + (fprintf out "#" zexpr)))) + + (define (store-path-realised path) + (define devirt (devirtualise-inner path)) + (define to-build (list)) + (for-each + (lambda (drv-and-outputs) + (for-each + (lambda (o) + (set! to-build (cons (string-append (derivation-path (car drv-and-outputs)) "!" o) to-build))) + (cdr drv-and-outputs))) + (list-ref devirt 1)) + (define val (car devirt)) (when (and (string? val) (not (file-exists? val)) (not (null? to-build))) (daemon-wop-build-paths (*daemon*) (list->vector to-build))) val)