[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
01/03: derivations: Move grafts to (guix grafts).
|
From: |
Ludovic Courtès |
|
Subject: |
01/03: derivations: Move grafts to (guix grafts). |
|
Date: |
Mon, 22 Feb 2016 21:12:51 +0000 |
civodul pushed a commit to branch master
in repository guix.
commit 7adf9b8469f3f043e61d1c9614aea8abb63fb727
Author: Ludovic Courtès <address@hidden>
Date: Mon Feb 22 16:29:44 2016 +0100
derivations: Move grafts to (guix grafts).
* guix/derivations.scm (<graft>, graft-derivation, %graft?)
(set-grafting): Move to...
* guix/grafts.scm: ... here. New file.
* guix/gexp.scm, guix/packages.scm, tests/packages.scm,
guix/scripts/build.scm: Use it.
* Makefile.am (MODULES): Add it.
(SCM_TESTS): Add tests/grafts.scm.
* tests/derivations.scm ("graft-derivation"): Move to...
* tests/grafts.scm: ... here. New file.
---
Makefile.am | 2 +
guix/derivations.scm | 98 -------------------------------------
guix/gexp.scm | 3 +-
guix/grafts.scm | 127 ++++++++++++++++++++++++++++++++++++++++++++++++
guix/packages.scm | 3 +-
guix/scripts/build.scm | 1 +
tests/derivations.scm | 34 -------------
tests/grafts.scm | 81 ++++++++++++++++++++++++++++++
tests/packages.scm | 3 +-
9 files changed, 217 insertions(+), 135 deletions(-)
diff --git a/Makefile.am b/Makefile.am
index 9beeb9d..01d7fbe 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -49,6 +49,7 @@ MODULES = \
guix/serialization.scm \
guix/nar.scm \
guix/derivations.scm \
+ guix/grafts.scm \
guix/gnu-maintenance.scm \
guix/upstream.scm \
guix/licenses.scm \
@@ -220,6 +221,7 @@ SCM_TESTS = \
tests/substitute.scm \
tests/builders.scm \
tests/derivations.scm \
+ tests/grafts.scm \
tests/ui.scm \
tests/records.scm \
tests/utils.scm \
diff --git a/guix/derivations.scm b/guix/derivations.scm
index 5db739a..1164774 100644
--- a/guix/derivations.scm
+++ b/guix/derivations.scm
@@ -85,21 +85,11 @@
derivation-path->output-paths
derivation
- graft
- graft?
- graft-origin
- graft-replacement
- graft-origin-output
- graft-replacement-output
- graft-derivation
-
map-derivation
build-derivations
built-derivations
- %graft?
- set-grafting
build-expression->derivation)
@@ -1111,81 +1101,6 @@ they can refer to each other."
#:guile-for-build guile
#:local-build? #t)))
-(define-record-type* <graft> graft make-graft
- graft?
- (origin graft-origin) ;derivation | store item
- (origin-output graft-origin-output ;string | #f
- (default "out"))
- (replacement graft-replacement) ;derivation | store item
- (replacement-output graft-replacement-output ;string | #f
- (default "out")))
-
-(define* (graft-derivation store name drv grafts
- #:key (guile (%guile-for-build))
- (system (%current-system)))
- "Return a derivation called NAME, based on DRV but with all the GRAFTS
-applied."
- ;; XXX: Someday rewrite using gexps.
- (define mapping
- ;; List of store item pairs.
- (map (match-lambda
- (($ <graft> source source-output target target-output)
- (cons (if (derivation? source)
- (derivation->output-path source source-output)
- source)
- (if (derivation? target)
- (derivation->output-path target target-output)
- target))))
- grafts))
-
- (define outputs
- (match (derivation-outputs drv)
- (((names . outputs) ...)
- (map derivation-output-path outputs))))
-
- (define output-names
- (match (derivation-outputs drv)
- (((names . outputs) ...)
- names)))
-
- (define build
- `(begin
- (use-modules (guix build graft)
- (guix build utils)
- (ice-9 match))
-
- (let ((mapping ',mapping))
- (for-each (lambda (input output)
- (format #t "grafting '~a' -> '~a'...~%" input output)
- (force-output)
- (rewrite-directory input output
- `((,input . ,output)
- ,@mapping)))
- ',outputs
- (match %outputs
- (((names . files) ...)
- files))))))
-
- (define add-label
- (cut cons "x" <>))
-
- (match grafts
- ((($ <graft> sources source-outputs targets target-outputs) ...)
- (let ((sources (zip sources source-outputs))
- (targets (zip targets target-outputs)))
- (build-expression->derivation store name build
- #:system system
- #:guile-for-build guile
- #:modules '((guix build graft)
- (guix build utils))
- #:inputs `(,@(map (lambda (out)
- `("x" ,drv ,out))
- output-names)
- ,@(append (map add-label
sources)
- (map add-label
targets)))
- #:outputs output-names
- #:local-build? #t)))))
-
(define* (build-expression->derivation store name exp ;deprecated
#:key
(system (%current-system))
@@ -1353,16 +1268,3 @@ ALLOWED-REFERENCES, LOCAL-BUILD?, and SUBSTITUTABLE?."
(define built-derivations
(store-lift build-derivations))
-
-;; The following might feel more at home in (guix packages) but since (guix
-;; gexp), which is a lower level, needs them, we put them here.
-
-(define %graft?
- ;; Whether to honor package grafts by default.
- (make-parameter #t))
-
-(define (set-grafting enable?)
- "This monadic procedure enables grafting when ENABLE? is true, and disables
-it otherwise. It returns the previous setting."
- (lambda (store)
- (values (%graft? enable?) store)))
diff --git a/guix/gexp.scm b/guix/gexp.scm
index 35adc17..87bc316 100644
--- a/guix/gexp.scm
+++ b/guix/gexp.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -20,6 +20,7 @@
#:use-module (guix store)
#:use-module (guix monads)
#:use-module (guix derivations)
+ #:use-module (guix grafts)
#:use-module (guix utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
diff --git a/guix/grafts.scm b/guix/grafts.scm
new file mode 100644
index 0000000..6b78a78
--- /dev/null
+++ b/guix/grafts.scm
@@ -0,0 +1,127 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;;
+;;; 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 (guix grafts)
+ #:use-module (guix records)
+ #:use-module (guix derivations)
+ #:use-module ((guix utils) #:select (%current-system))
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:export (graft?
+ graft
+ graft-origin
+ graft-replacement
+ graft-origin-output
+ graft-replacement-output
+
+ graft-derivation
+
+ %graft?
+ set-grafting))
+
+(define-record-type* <graft> graft make-graft
+ graft?
+ (origin graft-origin) ;derivation | store item
+ (origin-output graft-origin-output ;string | #f
+ (default "out"))
+ (replacement graft-replacement) ;derivation | store item
+ (replacement-output graft-replacement-output ;string | #f
+ (default "out")))
+
+(define* (graft-derivation store name drv grafts
+ #:key (guile (%guile-for-build))
+ (system (%current-system)))
+ "Return a derivation called NAME, based on DRV but with all the GRAFTS
+applied."
+ ;; XXX: Someday rewrite using gexps.
+ (define mapping
+ ;; List of store item pairs.
+ (map (match-lambda
+ (($ <graft> source source-output target target-output)
+ (cons (if (derivation? source)
+ (derivation->output-path source source-output)
+ source)
+ (if (derivation? target)
+ (derivation->output-path target target-output)
+ target))))
+ grafts))
+
+ (define outputs
+ (match (derivation-outputs drv)
+ (((names . outputs) ...)
+ (map derivation-output-path outputs))))
+
+ (define output-names
+ (match (derivation-outputs drv)
+ (((names . outputs) ...)
+ names)))
+
+ (define build
+ `(begin
+ (use-modules (guix build graft)
+ (guix build utils)
+ (ice-9 match))
+
+ (let ((mapping ',mapping))
+ (for-each (lambda (input output)
+ (format #t "grafting '~a' -> '~a'...~%" input output)
+ (force-output)
+ (rewrite-directory input output
+ `((,input . ,output)
+ ,@mapping)))
+ ',outputs
+ (match %outputs
+ (((names . files) ...)
+ files))))))
+
+ (define add-label
+ (cut cons "x" <>))
+
+ (match grafts
+ ((($ <graft> sources source-outputs targets target-outputs) ...)
+ (let ((sources (zip sources source-outputs))
+ (targets (zip targets target-outputs)))
+ (build-expression->derivation store name build
+ #:system system
+ #:guile-for-build guile
+ #:modules '((guix build graft)
+ (guix build utils))
+ #:inputs `(,@(map (lambda (out)
+ `("x" ,drv ,out))
+ output-names)
+ ,@(append (map add-label
sources)
+ (map add-label
targets)))
+ #:outputs output-names
+ #:local-build? #t)))))
+
+
+;; The following might feel more at home in (guix packages) but since (guix
+;; gexp), which is a lower level, needs them, we put them here.
+
+(define %graft?
+ ;; Whether to honor package grafts by default.
+ (make-parameter #t))
+
+(define (set-grafting enable?)
+ "This monadic procedure enables grafting when ENABLE? is true, and disables
+it otherwise. It returns the previous setting."
+ (lambda (store)
+ (values (%graft? enable?) store)))
+
+;;; grafts.scm ends here
diff --git a/guix/packages.scm b/guix/packages.scm
index 6ec168c..93bfbc4 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
;;; Copyright © 2014, 2015 Mark H Weaver <address@hidden>
;;; Copyright © 2015 Eric Bavier <address@hidden>
;;;
@@ -25,6 +25,7 @@
#:use-module (guix monads)
#:use-module (guix gexp)
#:use-module (guix base32)
+ #:use-module (guix grafts)
#:use-module (guix derivations)
#:use-module (guix build-system)
#:use-module (guix search-paths)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index aa9c105..8725dda 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -23,6 +23,7 @@
#:use-module (guix store)
#:use-module (guix derivations)
#:use-module (guix packages)
+ #:use-module (guix grafts)
#:use-module (guix utils)
#:use-module (guix monads)
#:use-module (guix gexp)
diff --git a/tests/derivations.scm b/tests/derivations.scm
index db96e26..9b53019 100644
--- a/tests/derivations.scm
+++ b/tests/derivations.scm
@@ -929,40 +929,6 @@
((p2 . _)
(string<? p1 p2)))))))))))))
-
-(test-assert "graft-derivation"
- (let* ((build `(begin
- (mkdir %output)
- (chdir %output)
- (symlink %output "self")
- (call-with-output-file "text"
- (lambda (output)
- (format output "foo/~a/bar" ,%mkdir)))
- (symlink ,%bash "sh")))
- (orig (build-expression->derivation %store "graft" build
- #:inputs `(("a" ,%bash)
- ("b" ,%mkdir))))
- (one (add-text-to-store %store "bash" "fake bash"))
- (two (build-expression->derivation %store "mkdir"
- '(call-with-output-file %output
- (lambda (port)
- (display "fake mkdir"
port)))))
- (graft (graft-derivation %store "graft" orig
- (list (graft
- (origin %bash)
- (replacement one))
- (graft
- (origin %mkdir)
- (replacement two))))))
- (and (build-derivations %store (list graft))
- (let ((two (derivation->output-path two))
- (graft (derivation->output-path graft)))
- (and (string=? (format #f "foo/~a/bar" two)
- (call-with-input-file (string-append graft "/text")
- get-string-all))
- (string=? (readlink (string-append graft "/sh")) one)
- (string=? (readlink (string-append graft "/self")) graft))))))
-
(test-equal "map-derivation"
"hello"
(let* ((joke (package-derivation %store guile-1.8))
diff --git a/tests/grafts.scm b/tests/grafts.scm
new file mode 100644
index 0000000..c11403b
--- /dev/null
+++ b/tests/grafts.scm
@@ -0,0 +1,81 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <address@hidden>
+;;;
+;;; 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-grafts)
+ #:use-module (guix derivations)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix grafts)
+ #:use-module (guix tests)
+ #:use-module ((gnu packages) #:select (search-bootstrap-binary))
+ #:use-module (srfi srfi-64)
+ #:use-module (rnrs io ports))
+
+(define %store
+ (open-connection-for-tests))
+
+(define (bootstrap-binary name)
+ (let ((bin (search-bootstrap-binary name (%current-system))))
+ (and %store
+ (add-to-store %store name #t "sha256" bin))))
+
+(define %bash
+ (bootstrap-binary "bash"))
+(define %mkdir
+ (bootstrap-binary "mkdir"))
+
+
+(test-begin "grafts")
+
+(test-assert "graft-derivation"
+ (let* ((build `(begin
+ (mkdir %output)
+ (chdir %output)
+ (symlink %output "self")
+ (call-with-output-file "text"
+ (lambda (output)
+ (format output "foo/~a/bar" ,%mkdir)))
+ (symlink ,%bash "sh")))
+ (orig (build-expression->derivation %store "graft" build
+ #:inputs `(("a" ,%bash)
+ ("b" ,%mkdir))))
+ (one (add-text-to-store %store "bash" "fake bash"))
+ (two (build-expression->derivation %store "mkdir"
+ '(call-with-output-file %output
+ (lambda (port)
+ (display "fake mkdir"
port)))))
+ (graft (graft-derivation %store "graft" orig
+ (list (graft
+ (origin %bash)
+ (replacement one))
+ (graft
+ (origin %mkdir)
+ (replacement two))))))
+ (and (build-derivations %store (list graft))
+ (let ((two (derivation->output-path two))
+ (graft (derivation->output-path graft)))
+ (and (string=? (format #f "foo/~a/bar" two)
+ (call-with-input-file (string-append graft "/text")
+ get-string-all))
+ (string=? (readlink (string-append graft "/sh")) one)
+ (string=? (readlink (string-append graft "/self")) graft))))))
+
+(test-end)
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))
diff --git a/tests/packages.scm b/tests/packages.scm
index 9d37fb6..68ab3f8 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <address@hidden>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -29,6 +29,7 @@
#:use-module (guix hash)
#:use-module (guix derivations)
#:use-module (guix packages)
+ #:use-module (guix grafts)
#:use-module (guix search-paths)
#:use-module (guix build-system)
#:use-module (guix build-system trivial)