mirror of
git://git.savannah.gnu.org/guix.git
synced 2023-12-14 03:33:07 +01:00
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.
This commit is contained in:
Ludovic Courtès
parent
73744725dd
commit
b41e21488f
|
|
@ -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 @@
|
|||
manifest-search-paths
|
||||
check-for-collisions
|
||||
|
||||
manifest->code
|
||||
|
||||
manifest-transaction
|
||||
manifest-transaction?
|
||||
manifest-transaction-install
|
||||
|
|
@ -667,6 +669,88 @@ including the search path specification for $PATH."
|
|||
(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.
|
||||
|
|
|
|||
|
|
@ -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 @@
|
|||
(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
|
||||
|
|
|
|||
Loading…
Reference in a new issue