(zilch magic): support devirtualising zexpr without losing zexpr-ness

Change-Id: I6a6a6964787b3a1fcd3223df258e34a8daba5dc8

core/src/magic.sld

@@ -3,7 +3,7 @@
 ;; A `<store-path>` 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 added-sources '())
-     (define drv-output-map #f)
-     (define placeholders-to-build '())
 
      (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 (devirtualise-inner zexpr)
-     (define ctx (zexp-unwrap (zexp (zexp-unquote path))))
+     (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))
+         (set! drvs (cons drv-and-outputs drvs))))
+      (zexp-evaluation-drvs ctx))
+     (if (string? val)
+       (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-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 "#<devirtualised ~S>" 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))))
+        (cdr drv-and-outputs)))
-      (zexp-evaluation-drvs ctx))
+      (list-ref devirt 1))
-     (if (string? val)
+     (define val (car devirt))
-       (set! val (resolve-upstream-output-placeholders val (zexp-evaluation-drvs ctx)))
-       (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))))
      (when (and (string? val) (not (file-exists? val)) (not (null? to-build)))
        (daemon-wop-build-paths (*daemon*) (list->vector to-build)))
      val)