1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
|
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2014, 2015, 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 (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
|
