(zilch core nixpkgs): allow evaluating arbitrary Nix code

core/src/nix/drv.sld

@@ -99,17 +99,20 @@
 
       (cached-data derivation-cached-data))
 
+    (define is-printing-drv (make-parameter #f))
     (define-record-printer (<derivation> drv out)
-      (fprintf out "#<derivation ~s ~s inputs: ~s ~s, ~s ~s ~s ~s, cached data ~S>"
-        (derivation-name drv)
-        (derivation-outputs drv)
-        (derivation-input-drvs drv)
-        (derivation-input-src drv)
-        (derivation-system drv)
-        (derivation-builder drv)
-        (derivation-args drv)
-        (derivation-env drv)
-        (derivation-cached-data drv)))
+      (define was-printing-drv (is-printing-drv))
+      (parameterize ((is-printing-drv #t))
+        (fprintf out "#<derivation ~s ~s inputs: ~s ~s, ~s ~s ~s ~s, cached data ~S>"
+          (derivation-name drv)
+          (derivation-outputs drv)
+          (if was-printing-drv (map derivation-name (derivation-input-drvs)) (derivation-input-drvs drv))
+          (derivation-input-src drv)
+          (derivation-system drv)
+          (derivation-builder drv)
+          (derivation-args drv)
+          (derivation-env drv)
+          (derivation-cached-data drv))))
 
     (define (write-delim-list start end fn val port)
       (write-char start port)

core/src/nixpkgs.sld

@@ -1,10 +1,12 @@
 (define-library (zilch nixpkgs)
   (import
-    (scheme base)
+    (scheme base) (scheme lazy)
     (zilch magic) (zilch nix drv) (zilch nix hash)
-    (srfi 18)
-    (chicken process))
-  (export nix-prefetch-url nixpkgs)
+    (zilch zexpr)
+    (srfi 18) (srfi 128) (srfi 146)
+    (chicken format) (chicken process)
+    json)
+  (export nix-prefetch-url nixpkgs nix-eval)
 
   (begin
     (define (run-stderr-thread prefix port)
@@ -23,6 +25,15 @@
       (define-values (_ _ _) (process-wait pid #t))
       (close-port stdout)
       drvpath)
+
+    (define (read-from-eval code)
+      (define-values (stdout stdin pid stderr) (process* "nix-instantiate" `("--json" "--eval" "--strict" "--read-write-mode" "-E" ,code)))
+      (define thread (thread-start! (make-thread (lambda () (run-stderr-thread (string-append "eval `" code "`") stderr)) "read-from-eval stderr passthrough")))
+      (close-port stdin)
+      (define output (json-read stdout))
+      (close-port stdout)
+      (define-values (_ _ _) (process-wait pid #t))
+      output)
    
     ;; Returns the hash (as bytevector) of prefetching the specified URL.
     (define (nix-prefetch-url name url)
@@ -45,4 +56,32 @@
                  (drv (read-drv-path drv-path))
                  (data (map (lambda (l) (cons (car l) (make-store-path drv (car l) #t))) (derivation-outputs drv))))
             (set! eval-cache (cons (cons path data) eval-cache))
-            data)))))
+            data)))
+
+    (define (nix-eval-inner code)
+      (define response (read-from-eval (string-append "(v: [(builtins.getContext (builtins.toJSON v)) v]) (" code ")")))
+      ; Format: key is drv,
+      ; path = true (always true if set, matches Opaque)
+      ; allOutputs = true (if set, matches DrvDeep, aka the .drv and its entire fucking closure)
+      ; outputs = [ ...output-name output-name-2 ] (matches Built)
+      (define drvs '())
+      (define paths '())
+      (vector-for-each
+       (lambda (item)
+        (define pairs (vector->list (cdr item)))
+        (when (assoc "path" pairs)
+         (set! paths (cons (car item) paths)))
+        (when (assoc "allOutputs" pairs)
+         (error "Context of evaluation output uses allOutputs; this is unsupported"))
+        (define outputs (let ((p (assoc "outputs" pairs))) (and p (cdr p))))
+        (when outputs
+         (let ((drv (read-drv-path (car item))))
+           (set! drvs (cons (cons drv outputs) drvs)))))
+       (car response))
+      (values drvs paths (cadr response)))
+
+    ;; Parse an arbitrary Nix expression and return it as a zexpr.
+    (define (nix-eval code)
+      (define data (delay (nix-eval-inner code)))
+      (make-zexp (lambda () (let-values (((drvs paths out) (force data))) (zexp-context-register-items drvs paths) out))
+                 (lambda (p) (fprintf p "nix`~A`" code))))))