diff --git a/guix/profiles.scm b/guix/profiles.scm index 59a313ea08..ea8bc6e593 100644 --- a/guix/profiles.scm +++ b/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 +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2013 Nikita Karetnikov ;;; Copyright © 2014, 2016 Alex Kost ;;; Copyright © 2015 Mark H Weaver @@ -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. diff --git a/tests/profiles.scm b/tests/profiles.scm index 2dec42bec1..ce77711d63 100644 --- a/tests/profiles.scm +++ b/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 +;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2014 Alex Kost ;;; ;;; 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