profiles: Add 'manifest->code'.

* guix/profiles.scm (manifest->code): New procedure.
* tests/profiles.scm ("manifest->code, simple")
("manifest->code, simple, versions")
("manifest->code, transformations"): New tests.

guix/profiles.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2014, 2016 Alex Kost <alezost@gmail.com>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
@@ -107,6 +107,8 @@ (define-module (guix profiles)
             manifest-search-paths
             check-for-collisions
 
+            manifest->code
+
             manifest-transaction
             manifest-transaction?
             manifest-transaction-install
@@ -667,6 +669,88 @@ (define (manifest-search-paths manifest)
          (append-map manifest-entry-search-paths
                      (manifest-entries manifest)))))
 
+(define* (manifest->code manifest
+                         #:key (entry-package-version (const "")))
+  "Return an sexp representing code to build an approximate version of
+MANIFEST; the code is wrapped in a top-level 'begin' form.  Call
+ENTRY-PACKAGE-VERSION to determine the version number to use in the spec for a
+given entry; it can be set to 'manifest-entry-version' for fully-specified
+version numbers, or to some other procedure to disambiguate versions for
+packages for which several versions are available."
+  (define (entry-transformations entry)
+    ;; Return the transformations that apply to ENTRY.
+    (assoc-ref (manifest-entry-properties entry) 'transformations))
+
+  (define transformation-procedures
+    ;; List of transformation options/procedure name pairs.
+    (let loop ((entries (manifest-entries manifest))
+               (counter 1)
+               (result  '()))
+      (match entries
+        (() result)
+        ((entry . tail)
+         (match (entry-transformations entry)
+           (#f
+            (loop tail counter result))
+           (options
+            (if (assoc-ref result options)
+                (loop tail counter result)
+                (loop tail (+ 1 counter)
+                      (alist-cons options
+                                  (string->symbol
+                                   (format #f "transform~a" counter))
+                                  result)))))))))
+
+  (define (qualified-name entry)
+    ;; Return the name of ENTRY possibly with "@" followed by a version.
+    (match (entry-package-version entry)
+      (""      (manifest-entry-name entry))
+      (version (string-append (manifest-entry-name entry)
+                              "@" version))))
+
+  (if (null? transformation-procedures)
+      `(begin                                     ;simplest case
+         (specifications->manifest
+          (list ,@(map (lambda (entry)
+                         (match (manifest-entry-output entry)
+                           ("out"  (qualified-name entry))
+                           (output (string-append (qualified-name entry)
+                                                  ":" output))))
+                       (manifest-entries manifest)))))
+      (let* ((transform (lambda (options exp)
+                          (if (not options)
+                              exp
+                              (let ((proc (assoc-ref transformation-procedures
+                                                     options)))
+                                `(,proc ,exp))))))
+        `(begin                                   ;transformations apply
+           (use-modules (guix transformations))
+
+           ,@(map (match-lambda
+                    ((options . name)
+                     `(define ,name
+                        (options->transformation ',options))))
+                  transformation-procedures)
+
+           (packages->manifest
+            (list ,@(map (lambda (entry)
+                           (define options
+                             (entry-transformations entry))
+
+                           (define name
+                             (qualified-name entry))
+
+                           (match (manifest-entry-output entry)
+                             ("out"
+                              (transform options
+                                         `(specification->package ,name)))
+                             (output
+                              `(list ,(transform
+                                       options
+                                       `(specification->package ,name))
+                                     ,output))))
+                         (manifest-entries manifest))))))))
+
 
 ;;;
 ;;; Manifest transactions.

tests/profiles.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Alex Kost <alezost@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -154,6 +154,34 @@ (define glibc
   (manifest-entries (manifest-add (manifest '())
                                   (list guile-2.0.9 guile-2.0.9))))
 
+(test-equal "manifest->code, simple"
+  '(begin
+     (specifications->manifest (list "guile" "guile:debug" "glibc")))
+  (manifest->code (manifest (list guile-2.0.9 guile-2.0.9:debug glibc))))
+
+(test-equal "manifest->code, simple, versions"
+  '(begin
+     (specifications->manifest (list "guile@2.0.9" "guile@2.0.9:debug"
+                                     "glibc@2.19")))
+  (manifest->code (manifest (list guile-2.0.9 guile-2.0.9:debug glibc))
+                  #:entry-package-version manifest-entry-version))
+
+(test-equal "manifest->code, transformations"
+  '(begin
+     (use-modules (guix transformations))
+
+     (define transform1
+       (options->transformation '((foo . "bar"))))
+
+     (packages->manifest
+      (list (transform1 (specification->package "guile"))
+            (specification->package "glibc"))))
+  (manifest->code (manifest (list (manifest-entry
+                                    (inherit guile-2.0.9)
+                                    (properties `((transformations
+                                                   . ((foo . "bar"))))))
+                                  glibc))))
+
 (test-assert "manifest-perform-transaction"
   (let* ((m0 (manifest (list guile-2.0.9 guile-2.0.9:debug)))
          (t1 (manifest-transaction