From 9a20830e57ea50dd73897725ad656a3b9e66f1ef Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 1 Jul 2012 00:37:03 +0200
Subject: Add `derivation-prerequisites' and
 `derivation-prerequisites-to-build'.

* guix/derivations.scm (derivation-prerequisites,
  derivation-prerequisites-to-build): New procedures.

* tests/derivations.scm ("build-expression->derivation and
  derivation-prerequisites", "build-expression->derivation and
  derivation-prerequisites-to-build"): New tests.
---
 guix/derivations.scm  | 43 ++++++++++++++++++++++++++++++++++++++++++-
 tests/derivations.scm | 19 ++++++++++++++++++-
 2 files changed, 60 insertions(+), 2 deletions(-)

diff --git a/guix/derivations.scm b/guix/derivations.scm
index 6011a3d97e..a2bff44a5f 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -26,19 +26,24 @@ (define-module (guix derivations)
   #:use-module (ice-9 rdelim)
   #:use-module (guix store)
   #:use-module (guix utils)
-  #:export (derivation?
+  #:export (<derivation>
+            derivation?
             derivation-outputs
             derivation-inputs
             derivation-sources
             derivation-system
             derivation-builder-arguments
             derivation-builder-environment-vars
+            derivation-prerequisites
+            derivation-prerequisites-to-build
 
+            <derivation-output>
             derivation-output?
             derivation-output-path
             derivation-output-hash-algo
             derivation-output-hash
 
+            <derivation-input>
             derivation-input?
             derivation-input-path
             derivation-input-sub-derivations
@@ -92,6 +97,42 @@ (define (fixed-output-derivation? drv)
      #t)
     (_ #f)))
 
+(define (derivation-prerequisites drv)
+  "Return the list of derivation-inputs required to build DRV, recursively."
+  (let loop ((drv    drv)
+             (result '()))
+    (let ((inputs (remove (cut member <> result)  ; XXX: quadratic
+                          (derivation-inputs drv))))
+      (fold loop
+            (append inputs result)
+            (map (lambda (i)
+                   (call-with-input-file (derivation-input-path i)
+                     read-derivation))
+                 inputs)))))
+
+(define (derivation-prerequisites-to-build store drv)
+  "Return the list of derivation-inputs required to build DRV and not already
+available in STORE, recursively."
+  (define input-built?
+    (match-lambda
+     (($ <derivation-input> path sub-drvs)
+      (let ((out (map (cut derivation-path->output-path path <>)
+                      sub-drvs)))
+        (any (cut valid-path? store <>) out)))))
+
+  (let loop ((drv    drv)
+             (result '()))
+    (let ((inputs (remove (lambda (i)
+                            (or (member i result) ; XXX: quadratic
+                                (input-built? i)))
+                          (derivation-inputs drv))))
+      (fold loop
+            (append inputs result)
+            (map (lambda (i)
+                   (call-with-input-file (derivation-input-path i)
+                     read-derivation))
+                 inputs)))))
+
 (define (read-derivation drv-port)
   "Read the derivation from DRV-PORT and return the corresponding
 <derivation> object."
diff --git a/tests/derivations.scm b/tests/derivations.scm
index 3fc7097a87..b6bd4dab0d 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -172,7 +172,16 @@ (define %coreutils
            (and (valid-path? %store p)
                 (file-exists? (string-append p "/good")))))))
 
-(test-skip (if (%guile-for-build) 0 4))
+(test-skip (if (%guile-for-build) 0 6))
+
+(test-assert "build-expression->derivation and derivation-prerequisites"
+  (let-values (((drv-path drv)
+                (build-expression->derivation %store "fail" (%current-system)
+                                              #f '())))
+    (any (match-lambda
+          (($ <derivation-input> path)
+           (string=? path (%guile-for-build))))
+         (derivation-prerequisites drv))))
 
 (test-assert "build-expression->derivation without inputs"
   (let* ((builder    '(begin
@@ -188,6 +197,14 @@ (define %coreutils
            (equal? '(hello guix)
                    (call-with-input-file (string-append p "/test") read))))))
 
+(test-assert "build-expression->derivation and derivation-prerequisites-to-build"
+  (let-values (((drv-path drv)
+                (build-expression->derivation %store "fail" (%current-system)
+                                              #f '())))
+    ;; The only direct dependency is (%guile-for-build) and it's already
+    ;; built.
+    (null? (derivation-prerequisites-to-build %store drv))))
+
 (test-assert "build-expression->derivation with expression returning #f"
   (let* ((builder  '(begin
                       (mkdir %output)
-- 
cgit v1.2.3