12/15: home: import: Avoid duplication of 'manifest->code'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 6f4ca78761471602e3af37ee1a33de446114039f
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sun Oct 31 00:02:27 2021 +0200

    home: import: Avoid duplication of 'manifest->code'.
    
    * guix/scripts/home/import.scm (manifest->code): Remove.
    (manifest+configuration-files->code): New procedure.
    (import-manifest): Use 'manifest+configuration-files->code' instead of
    'manifest->code'.
    * tests/home-import.scm (eval-test-with-home-environment): Likewise.
    (match-home-environment-transformations): New procedure.
    ("manifest->code: No services, package transformations"): New test.
---
 guix/scripts/home/import.scm | 176 ++++++++++---------------------------------
 tests/home-import.scm        |  33 +++++++-
 2 files changed, 69 insertions(+), 140 deletions(-)

diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm
index 8f6b3b5..7a7712d 100644
--- a/guix/scripts/home/import.scm
+++ b/guix/scripts/home/import.scm
@@ -1,6 +1,7 @@
 ;;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
 ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in>
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -31,7 +32,7 @@
   #:export (import-manifest
 
             ;; For tests.
-            manifest->code))
+            manifest+configuration-files->code))
 
 ;;; Commentary:
 ;;;
@@ -105,146 +106,49 @@ in CONFIGURATION-DIRECTORY."
 
   (map (lambda (proc) (proc configuration-directory)) configurations))
 
-;; Based on `manifest->code' from (guix profiles)
-;; MAYBE: Upstream it?
-(define* (manifest->code manifest destination-directory
-                         #:key
-                         (entry-package-version (const ""))
-                         (home-environment? #f))
-  "Return an sexp representing code to build an approximate version of
-MANIFEST; the code is wrapped in a top-level 'begin' form.  If
-HOME-ENVIRONMENT? is #t, return an <home-environment> definition.
-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)
-      (let ((specs (map (lambda (entry)
-                          (match (manifest-entry-output entry)
-                            ("out"  (qualified-name entry))
-                            (output (string-append (qualified-name entry)
-                                                   ":" output))))
-                        (manifest-entries manifest))))
-        (if home-environment?
-            (let ((configurations+modules
-                   (configurations+modules destination-directory)))
-              `(begin
-                 (use-modules (gnu home)
-                              (gnu packages)
-                              (gnu services)
-                              ,@((compose delete-duplicates concatenate)
-                                 (map cdr configurations+modules)))
-                 ,(home-environment-template
-                   #:specs specs
-                   #:services (map first configurations+modules))))
-            `(begin
-               (use-modules (gnu packages))
-
-               (specifications->manifest
-                (list ,@specs)))))
-      (let* ((transform (lambda (options exp)
-                         (if (not options)
-                             exp
-                             (let ((proc (assoc-ref transformation-procedures
-                                                    options)))
-                               `(,proc ,exp)))))
-            (packages (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)))
-            (transformations (map (match-lambda
-                         ((options . name)
-                          `(define ,name
-                             (options->transformation ',options))))
-                       transformation-procedures)))
-        (if home-environment?
-            (let ((configurations+modules
-                   (configurations+modules destination-directory)))
-              `(begin
-                 (use-modules (guix transformations)
-                              (gnu home)
-                              (gnu packages)
-                              (gnu services)
-                              ,@((compose delete-duplicates concatenate)
-                                 (map cdr configurations+modules)))
-
-                 ,@transformations
-
-                 ,(home-environment-template
-                   #:packages packages
-                   #:services (map first configurations+modules))))
-            `(begin
-               (use-modules (guix transformations)
-                            (gnu packages))
-
-                ,@transformations
-
-                (packages->manifest
-                 (list ,@packages)))))))
-
-(define* (home-environment-template #:key (packages #f) (specs #f) services)
-  "Return an S-exp containing a <home-environment> declaration
-containing PACKAGES, or SPECS (package specifications), and SERVICES."
-  `(home-environment
-     (packages
-      ,@(if packages
-            `((list ,@packages))
-            `((map specification->package
-                   (list ,@specs)))))
-     (services (list ,@services))))
+(define (manifest+configuration-files->code manifest
+                                            configuration-directory)
+  "Read MANIFEST and the user's configuration files listed in
+%FILES+CONFIGURATIONS-ALIST, and return a 'home-environment' sexp.  Copy the
+user's files to CONFIGURATION-DIRECTORY; the generated sexp refers to them."
+  (match (manifest->code manifest
+                         #:entry-package-version
+                         manifest-entry-version-prefix)
+    (('begin ('use-modules profile-modules ...)
+             definitions ... ('packages->manifest packages))
+     (match (configurations+modules configuration-directory)
+       (((services . modules) ...)
+        `(begin
+           (use-modules (gnu home)
+                        (gnu packages)
+                        (gnu services)
+                        ,@(delete-duplicates
+                           (append profile-modules (concatenate modules))))
+
+           ,@definitions
+
+           (home-environment
+            (packages ,packages)
+            (services (list ,@services)))))))
+    (('begin ('specifications->manifest packages))
+     (match (configurations+modules configuration-directory)
+       (((services . modules) ...)
+        `(begin
+           (use-modules (gnu home)
+                        (gnu packages)
+                        (gnu services)
+                        ,@(delete-duplicates (concatenate modules)))
+
+           (home-environment
+            (packages (map specification->package ,packages))
+            (services (list ,@services)))))))))
 
 (define* (import-manifest
           manifest destination-directory
           #:optional (port (current-output-port)))
   "Write to PORT a <home-environment> corresponding to MANIFEST."
-  (match (manifest->code manifest destination-directory
-                         #:entry-package-version manifest-entry-version-prefix
-                         #:home-environment? #t)
+  (match (manifest+configuration-files->code manifest
+                                             destination-directory)
     (('begin exp ...)
      (format port (G_ "\
 ;; This \"home-environment\" file can be passed to 'guix home reconfigure'
diff --git a/tests/home-import.scm b/tests/home-import.scm
index dc413d8..abd3cec 100644
--- a/tests/home-import.scm
+++ b/tests/home-import.scm
@@ -87,10 +87,8 @@ corresponding file."
   (create-temporary-home files-alist)
   (setenv "HOME" %temporary-home-directory)
   (mkdir-p %temporary-home-directory)
-  (let* ((home-environment (manifest->code manifest %destination-directory
-                                           #:entry-package-version
-                                           manifest-entry-version-prefix
-                                           #:home-environment? #t))
+  (let* ((home-environment (manifest+configuration-files->code
+                            manifest %destination-directory))
          (result (matcher home-environment)))
     (delete-file-recursively %temporary-home-directory)
     result))
@@ -108,6 +106,22 @@ corresponding file."
      ('services
       ('list)))))
 
+(define-home-environment-matcher match-home-environment-transformations
+  ('begin
+    ('use-modules
+     ('gnu 'home)
+     ('gnu 'packages)
+     ('gnu 'services)
+     ('guix 'transformations))
+
+    ('define transform ('options->transformation _))
+    ('home-environment
+     ('packages
+      ('list (transform ('specification->package "guile@2.0.9"))
+             ('specification->package "gcc")
+             ('specification->package "glibc@2.19")))
+     ('services ('list)))))
+
 (define-home-environment-matcher 
match-home-environment-no-services-nor-packages
   ('begin
     ('use-modules
@@ -141,12 +155,23 @@ corresponding file."
                 ('list ('local-file "/tmp/guix-config/.bashrc"
                                     "bashrc"))))))))))
 
+
 (test-assert "manifest->code: No services"
   (eval-test-with-home-environment
    '()
    (make-manifest (list guile-2.0.9 gcc glibc))
    match-home-environment-no-services))
 
+(test-assert "manifest->code: No services, package transformations"
+  (eval-test-with-home-environment
+   '()
+   (make-manifest (list (manifest-entry
+                          (inherit guile-2.0.9)
+                          (properties `((transformations
+                                         . ((foo . "bar"))))))
+                        gcc glibc))
+   match-home-environment-transformations))
+
 (test-assert "manifest->code: No packages nor services"
   (eval-test-with-home-environment
    '()