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
|
;;; SPDX-License-Identifier: GPL-3.0-or-later
;;; Copyright © 2019 Pierre Neidhardt <mail@ambrevar.xyz>
;;; Copyright © 2020 Jonathan Brielmaier <jonathan.brielmaier@web.de>
(define-module (nonguix utils)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-43)
#:use-module (ice-9 match)
#:use-module (ice-9 textual-ports)
#:use-module (ice-9 popen)
#:use-module (guix utils)
#:use-module (guix packages)
#:use-module (gnu services)
#:export (package-input-grafting
package-with-alias
with-transformation))
(define-public (to32 package64)
"Build package for i686-linux.
Only x86_64-linux and i686-linux are supported.
- If i686-linux, return the package unchanged.
- If x86_64-linux, return the 32-bit version of the package."
(match (%current-system)
("x86_64-linux"
(package
(inherit package64)
(arguments `(#:system "i686-linux"
,@(package-arguments package64)))))
(_ package64)))
(define (package-input-grafting replacements)
"Return a procedure that, when passed a package, grafts its direct and
indirect dependencies, including implicit inputs, according to REPLACEMENTS.
REPLACEMENTS is a list of package pairs; the first element of each pair is the
package to replace, and the second one is the replacement.
Name and version of replacement packages will be padded to meet graft
requirement."
(package-input-rewriting
(map (match-lambda
((old . new)
`(,old . ,(package
(inherit old)
(replacement
(package
(inherit new)
(name
(string-pad-right
(package-name new)
(string-length (package-name old))
#\0))
(version
(string-pad-right
(package-version new)
(string-length (package-version old))
#\0))))))))
replacements)))
;; For concerns and direction of improvement, see this thread:
;; https://lists.gnu.org/archive/html/guix-devel/2024-06/msg00275.html
(define* (with-transformation proc obj #:optional (pred package?))
"Recursing into child elements, apply PROC to every element of OBJ that
matches PRED."
(match obj
((? pred)
(proc obj))
((a . b)
(cons (with-transformation proc a pred)
(with-transformation proc b pred)))
((_ ...)
(map (cut with-transformation proc <> pred)
obj))
(#(_ ...)
(vector-map (lambda (vec elt)
(with-transformation proc elt pred))
obj))
;; `<service-type>' and `<origin>' record types are expected to not be
;; modified. Altering them causes very difficult to debug run-time errors.
((or (? service-type?)
(? origin?))
obj)
((? record?)
(cond
;; Both ‘file-systems’ and ‘boot-file-system-utilities’ services extends
;; ‘profile-service-type’ with the same package, however information of
;; the former one is hidden from us, causing conflict in the resulted
;; profile.
((and (service? obj)
(eq? 'boot-file-system-utilities
(service-type-name (service-kind obj))))
obj)
(else
(let* ((record-type (record-type-descriptor obj))
(record-fields (record-type-fields record-type)))
(apply (record-constructor record-type)
(map (lambda (field)
(let* ((accessor (record-accessor record-type field))
(obj (accessor obj)))
(with-transformation proc obj pred)))
record-fields))))))
;; TODO: Check if this can be handled as well.
((? parameter?)
obj)
((? procedure?)
(lambda args
(apply values
(map (cut with-transformation proc <> pred)
(call-with-values
(lambda ()
(apply obj args))
list)))))
(_ obj)))
(define (package-with-alias alias pkg)
"Return a copy of package PKG called ALIAS."
(package
(inherit pkg)
(name alias)))
|
