ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 05:18:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

guix build: Transformations operate on single objects.

Browse source 
* guix/scripts/build.scm (transform-package-source): Return a procedure
that expects a single object rather than a list of packages.
(options->transformation): Rewrite to precompute the list of applicable
transformations and to return a procedure that expects a single object
rather than a list of objects.
(options->derivations): Adjust accordingly.
* tests/scripts-build.scm: New file.
* Makefile.am (SCM_TESTS): Add it.
This commit is contained in:
Ludovic Courtès 2016-01-31 20:18:52 +01:00
parent efdcb6f29c
commit 629a064f32
3 changed files with 107 additions and 36 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
Makefile.am
View file

@ -243,6 +243,7 @@ SCM_TESTS = \
tests/file-systems.scm \
tests/system.scm \
tests/services.scm \
tests/scripts-build.scm \
tests/containers.scm \
tests/import-utils.scm

69
guix/scripts/build.scm
View file

@ -41,6 +41,7 @@ (define-module (guix scripts build)
set-build-options-from-command-line
set-build-options-from-command-line*
show-build-options-help
options->transformation
guix-build))
@ -484,39 +485,29 @@ (define graft? (assoc-ref opts 'graft?))
(set-guile-for-build (default-guile))
(gexp->derivation "gexp" gexp
#:system system))))))
(transform store (options->things-to-build opts)))))
(map (cut transform store <>)
(options->things-to-build opts)))))
(define (transform-package-source sources)
"Return a transformation procedure that uses replaces package sources with
the matching URIs given in SOURCES."
"Return a transformation procedure that replaces package sources with the
matching URIs given in SOURCES."
(define new-sources
(map (lambda (uri)
(cons (package-name->name+version (basename uri))
uri))
sources))
(lambda (store packages)
(let loop ((packages packages)
(sources new-sources)
(lambda (store obj)
(let loop ((sources new-sources)
(result '()))
(match packages
(()
(unless (null? sources)
(warning (_ "sources do not match any package:~{ ~a~}~%")
(match sources
(((name . uri) ...)
uri))))
(reverse result))
(((? package? p) tail ...)
(match obj
((? package? p)
(let ((source (assoc-ref sources (package-name p))))
(loop tail
(alist-delete (package-name p) sources)
(cons (if source
(if source
(package-with-source store p source)
p)
result))))
((thing tail ...)
(loop tail sources result))))))
p)))
(_
obj)))))
(define %transformations
;; Transformations that can be applied to things to build. The car is the
@ -526,19 +517,33 @@ (define %transformations
`((with-source . ,transform-package-source)))
(define (options->transformation opts)
"Return a procedure that, when passed a list of things to build (packages,
derivations, etc.), applies the transformations specified by OPTS."
(apply compose
(map (match-lambda
"Return a procedure that, when passed an object to build (package,
derivation, etc.), applies the transformations specified by OPTS."
(define applicable
;; List of applicable transformations as symbol/procedure pairs.
(filter-map (match-lambda
((key . transform)
(let ((args (filter-map (match-lambda
(match (filter-map (match-lambda
((k . arg)
(and (eq? k key) arg)))
opts)))
(if (null? args)
(lambda (store things) things)
(transform args)))))
%transformations)))
opts)
(() #f)
(args (cons key (transform args))))))
%transformations))
(lambda (store obj)
(fold (match-lambda*
(((name . transform) obj)
(let ((new (transform store obj)))
(when (eq? new obj)
(warning (_ "transformation '~a' had no effect on ~a~%")
name
(if (package? obj)
(package-full-name obj)
obj)))
new)))
obj
applicable)))
(define (show-build-log store file urls)
"Show the build log for FILE, falling back to remote logs from URLS if

65
tests/scripts-build.scm Normal file
View file

@ -0,0 +1,65 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2016 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-scripts-build)
#:use-module (guix tests)
#:use-module (guix store)
#:use-module (guix packages)
#:use-module (guix scripts build)
#:use-module (guix ui)
#:use-module (srfi srfi-64))
(test-begin "scripts-build")
(test-assert "options->transformation, no transformations"
(let ((p (dummy-package "foo"))
(t (options->transformation '())))
(with-store store
(eq? (t store p) p))))
(test-assert "options->transformation, with-source"
;; Our pseudo-package is called 'guix.scm' so the 'guix.scm' source should
;; be applicable.
(let* ((p (dummy-package "guix.scm"))
(s (search-path %load-path "guix.scm"))
(t (options->transformation `((with-source . ,s)))))
(with-store store
(let ((new (t store p)))
(and (not (eq? new p))
(string=? (package-source new)
(add-to-store store "guix.scm" #t
"sha256" s)))))))
(test-assert "options->transformation, with-source, no matches"
;; When a transformation in not applicable, a warning must be raised.
(let* ((p (dummy-package "foobar"))
(s (search-path %load-path "guix.scm"))
(t (options->transformation `((with-source . ,s)))))
(with-store store
(let* ((port (open-output-string))
(new (parameterize ((guix-warning-port port))
(t store p))))
(and (eq? new p)
(string-contains (get-output-string port)
"had no effect"))))))
(test-end)
(exit (= (test-runner-fail-count (test-runner-current)) 0))