From 6f4ca78761471602e3af37ee1a33de446114039f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Ludovic=20Court=C3=A8s?= Date: Sun, 31 Oct 2021 00:02:27 +0200 Subject: [PATCH] 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 | 170 ++++++++--------------------------- tests/home-import.scm | 33 ++++++- 2 files changed, 66 insertions(+), 137 deletions(-) diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm index 8f6b3b58aa..7a7712dd96 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 ;;; Copyright © 2021 Andrew Tropin +;;; Copyright © 2021 Ludovic Courtès ;;; ;;; 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 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 (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)))) - (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))))))))) + ,@definitions - (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)))) + (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))) - (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 declaration -containing PACKAGES, or SPECS (package specifications), and SERVICES." - `(home-environment - (packages - ,@(if packages - `((list ,@packages)) - `((map specification->package - (list ,@specs))))) - (services (list ,@services)))) + (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 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 dc413d8516..abd3cec43d 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 '()