02/06: profiles: Represent propagated inputs as manifest entries.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 55b4715fd4c03e46501f123c5c9bc6072edf12a4
Author: Ludovic Courtès <address@hidden>
Date:   Tue Jun 6 14:01:12 2017 +0200

    profiles: Represent propagated inputs as manifest entries.
    
    * guix/profiles.scm (package->manifest-entry): Turn DEPS into a list of
    manifest entries.
    (manifest->gexp)[entry->gexp]: Call 'entry->gexp' on DEPS.
    Bump version to 3.
    (sexp->manifest)[infer-dependency]: New procedure.
    Use it for versions 1 and 2.  Parse version 3.
    (manifest-inputs)[entry->gexp]: New procedure.
    Adjust to 'dependencies' being a list of <manifest-entry>.
    * tests/profiles.scm ("packages->manifest, propagated inputs")
    ("read-manifest"): New fields.
---
 guix/profiles.scm  | 73 +++++++++++++++++++++++++++++++++++++++---------------
 tests/profiles.scm | 36 +++++++++++++++++++++++++++
 2 files changed, 89 insertions(+), 20 deletions(-)

diff --git a/guix/profiles.scm b/guix/profiles.scm
index 6733f10..a66add3 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -154,7 +154,7 @@
   (output       manifest-entry-output             ; string
                 (default "out"))
   (item         manifest-entry-item)              ; package | store path
-  (dependencies manifest-entry-dependencies       ; (store path | package)*
+  (dependencies manifest-entry-dependencies       ; <manifest-entry>*
                 (default '()))
   (search-paths manifest-entry-search-paths       ; search-path-specification*
                 (default '())))
@@ -179,10 +179,10 @@
   "Return a manifest entry for the OUTPUT of package PACKAGE."
   (let ((deps (map (match-lambda
                     ((label package)
-                     (gexp-input package))
+                     (package->manifest-entry package))
                     ((label package output)
-                     (gexp-input package output)))
-                   (package-transitive-propagated-inputs package))))
+                     (package->manifest-entry package output)))
+                   (package-propagated-inputs package))))
     (manifest-entry
      (name (package-name package))
      (version (package-version package))
@@ -210,20 +210,20 @@ denoting a specific output of a package."
       (($ <manifest-entry> name version output (? string? path)
                            (deps ...) (search-paths ...))
        #~(#$name #$version #$output #$path
-                 (propagated-inputs #$deps)
+                 (propagated-inputs #$(map entry->gexp deps))
                  (search-paths #$(map search-path-specification->sexp
                                       search-paths))))
       (($ <manifest-entry> name version output (? package? package)
                            (deps ...) (search-paths ...))
        #~(#$name #$version #$output
                  (ungexp package (or output "out"))
-                 (propagated-inputs #$deps)
+                 (propagated-inputs #$(map entry->gexp deps))
                  (search-paths #$(map search-path-specification->sexp
                                       search-paths))))))
 
   (match manifest
     (($ <manifest> (entries ...))
-     #~(manifest (version 2)
+     #~(manifest (version 3)
                  (packages #$(map entry->gexp entries))))))
 
 (define (find-package name version)
@@ -254,17 +254,27 @@ procedure is here for backward-compatibility and will 
eventually vanish."
           (package-native-search-paths package)
           '())))
 
+  (define (infer-dependency item)
+    ;; Return a <manifest-entry> for ITEM.
+    (let-values (((name version)
+                  (package-name->name+version
+                   (store-path-package-name item))))
+      (manifest-entry
+        (name name)
+        (version version)
+        (item item))))
+
   (match sexp
     (('manifest ('version 0)
                 ('packages ((name version output path) ...)))
      (manifest
       (map (lambda (name version output path)
              (manifest-entry
-              (name name)
-              (version version)
-              (output output)
-              (item path)
-              (search-paths (infer-search-paths name version))))
+               (name name)
+               (version version)
+               (output output)
+               (item path)
+               (search-paths (infer-search-paths name version))))
            name version output path)))
 
     ;; Version 1 adds a list of propagated inputs to the
@@ -286,7 +296,7 @@ procedure is here for backward-compatibility and will 
eventually vanish."
                  (version version)
                  (output output)
                  (item path)
-                 (dependencies deps)
+                 (dependencies (map infer-dependency deps))
                  (search-paths (infer-search-paths name version)))))
            name version output path deps)))
 
@@ -304,10 +314,30 @@ procedure is here for backward-compatibility and will 
eventually vanish."
                (version version)
                (output output)
                (item path)
-               (dependencies deps)
+               (dependencies (map infer-dependency deps))
                (search-paths (map sexp->search-path-specification
                                   search-paths))))
            name version output path deps search-paths)))
+
+    ;; Version 3 represents DEPS as full-blown manifest entries.
+    (('manifest ('version 3 minor-version ...)
+                ('packages (entries ...)))
+     (letrec ((sexp->manifest-entry
+               (match-lambda
+                 ((name version output path
+                        ('propagated-inputs deps)
+                        ('search-paths search-paths)
+                        extra-stuff ...)
+                  (manifest-entry
+                    (name name)
+                    (version version)
+                    (output output)
+                    (item path)
+                    (dependencies (map sexp->manifest-entry deps))
+                    (search-paths (map sexp->search-path-specification
+                                       search-paths)))))))
+
+       (manifest (map sexp->manifest-entry entries))))
     (_
      (raise (condition
              (&message (message "unsupported manifest format")))))))
@@ -471,12 +501,15 @@ replace it."
 
 (define (manifest-inputs manifest)
   "Return a list of <gexp-input> objects for MANIFEST."
-  (append-map (match-lambda
-               (($ <manifest-entry> name version output thing deps)
-                ;; THING may be a package or a file name.  In the latter case,
-                ;; assume it's already valid.  Ditto for DEPS.
-                (cons (gexp-input thing output) deps)))
-              (manifest-entries manifest)))
+  (define entry->input
+    (match-lambda
+      (($ <manifest-entry> name version output thing deps)
+       ;; THING may be a package or a file name.  In the latter case, assume
+       ;; it's already valid.
+       (cons (gexp-input thing output)
+             (append-map entry->input deps)))))
+
+  (append-map entry->input (manifest-entries manifest)))
 
 (define* (manifest-lookup-package manifest name #:optional version)
   "Return as a monadic value the first package or store path referenced by
diff --git a/tests/profiles.scm b/tests/profiles.scm
index 0934227..e8b1bb8 100644
--- a/tests/profiles.scm
+++ b/tests/profiles.scm
@@ -288,6 +288,42 @@
            (manifest-entry-search-paths
             (package->manifest-entry mpl)))))
 
+(test-equal "packages->manifest, propagated inputs"
+  (map (match-lambda
+         ((label package)
+          (list (package-name package) (package-version package)
+                package)))
+       (package-propagated-inputs packages:guile-2.2))
+  (map (lambda (entry)
+         (list (manifest-entry-name entry)
+               (manifest-entry-version entry)
+               (manifest-entry-item entry)))
+       (manifest-entry-dependencies
+        (package->manifest-entry packages:guile-2.2))))
+
+(test-assertm "read-manifest"
+  (mlet* %store-monad ((manifest -> (packages->manifest
+                                     (list (package
+                                             (inherit %bootstrap-guile)
+                                             (native-search-paths
+                                              (package-native-search-paths
+                                               packages:guile-2.0))))))
+                       (drv (profile-derivation manifest
+                                                #:hooks '()
+                                                #:locales? #f))
+                       (out -> (derivation->output-path drv)))
+    (define (entry->sexp entry)
+      (list (manifest-entry-name entry)
+            (manifest-entry-version entry)
+            (manifest-entry-search-paths entry)
+            (manifest-entry-dependencies entry)))
+
+    (mbegin %store-monad
+      (built-derivations (list drv))
+      (let ((manifest2 (profile-manifest out)))
+        (return (equal? (map entry->sexp (manifest-entries manifest))
+                        (map entry->sexp (manifest-entries manifest2))))))))
+
 (test-assertm "etc/profile"
   ;; Make sure we get an 'etc/profile' file that at least defines $PATH.
   (mlet* %store-monad