Commit | Line | Data |
---|---|---|
eaae07ec LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2017, 2018 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix self) | |
20 | #:use-module (guix config) | |
21 | #:use-module (guix i18n) | |
22 | #:use-module (guix modules) | |
23 | #:use-module (guix gexp) | |
24 | #:use-module (guix store) | |
25 | #:use-module (guix monads) | |
26 | #:use-module (guix discovery) | |
27 | #:use-module (guix packages) | |
28 | #:use-module (guix sets) | |
eaae07ec | 29 | #:use-module (guix modules) |
45779fa6 | 30 | #:use-module ((guix build utils) #:select (find-files)) |
eaae07ec LC |
31 | #:use-module ((guix build compile) #:select (%lightweight-optimizations)) |
32 | #:use-module (srfi srfi-1) | |
33 | #:use-module (srfi srfi-9) | |
34 | #:use-module (ice-9 match) | |
35 | #:export (make-config.scm | |
8a0d9bc8 | 36 | whole-package ;for internal use in 'guix pull' |
eaae07ec LC |
37 | compiled-guix |
38 | guix-derivation | |
39 | reload-guix)) | |
40 | ||
41 | \f | |
42 | ;;; | |
43 | ;;; Dependency handling. | |
44 | ;;; | |
45 | ||
46 | (define* (false-if-wrong-guile package | |
47 | #:optional (guile-version (effective-version))) | |
48 | "Return #f if PACKAGE depends on the \"wrong\" major version of Guile (e.g., | |
49 | 2.0 instead of 2.2), otherwise return PACKAGE." | |
50 | (let ((guile (any (match-lambda | |
51 | ((label (? package? dep) _ ...) | |
52 | (and (string=? (package-name dep) "guile") | |
53 | dep))) | |
54 | (package-direct-inputs package)))) | |
55 | (and (or (not guile) | |
56 | (string-prefix? guile-version | |
57 | (package-version guile))) | |
58 | package))) | |
59 | ||
60 | (define (package-for-guile guile-version . names) | |
61 | "Return the package with one of the given NAMES that depends on | |
62 | GUILE-VERSION (\"2.0\" or \"2.2\"), or #f if none of the packages matches." | |
63 | (let loop ((names names)) | |
64 | (match names | |
65 | (() | |
66 | #f) | |
67 | ((name rest ...) | |
68 | (match (specification->package name) | |
69 | (#f | |
70 | (loop rest)) | |
71 | ((? package? package) | |
a1639ae9 | 72 | (or (false-if-wrong-guile package guile-version) |
eaae07ec LC |
73 | (loop rest)))))))) |
74 | ||
75 | (define specification->package | |
76 | ;; Use our own variant of that procedure because that of (gnu packages) | |
77 | ;; would traverse all the .scm files, which is wasteful. | |
78 | (let ((ref (lambda (module variable) | |
79 | (module-ref (resolve-interface module) variable)))) | |
80 | (match-lambda | |
81 | ("guile" (ref '(gnu packages commencement) 'guile-final)) | |
82 | ("guile-json" (ref '(gnu packages guile) 'guile-json)) | |
83 | ("guile-ssh" (ref '(gnu packages ssh) 'guile-ssh)) | |
84 | ("guile-git" (ref '(gnu packages guile) 'guile-git)) | |
d59e75f3 | 85 | ("guile-sqlite3" (ref '(gnu packages guile) 'guile-sqlite3)) |
ca719424 | 86 | ("guile-gcrypt" (ref '(gnu packages gnupg) 'guile-gcrypt)) |
108015df | 87 | ("gnutls" (ref '(gnu packages tls) 'gnutls)) |
eaae07ec LC |
88 | ("zlib" (ref '(gnu packages compression) 'zlib)) |
89 | ("gzip" (ref '(gnu packages compression) 'gzip)) | |
90 | ("bzip2" (ref '(gnu packages compression) 'bzip2)) | |
91 | ("xz" (ref '(gnu packages compression) 'xz)) | |
e69dd844 LC |
92 | ("guile2.0-json" (ref '(gnu packages guile) 'guile2.0-json)) |
93 | ("guile2.0-ssh" (ref '(gnu packages ssh) 'guile2.0-ssh)) | |
94 | ("guile2.0-git" (ref '(gnu packages guile) 'guile2.0-git)) | |
d59e75f3 | 95 | ;; XXX: No "guile2.0-sqlite3". |
108015df | 96 | ("guile2.0-gnutls" (ref '(gnu packages tls) 'gnutls/guile-2.0)) |
e69dd844 | 97 | (_ #f)))) ;no such package |
eaae07ec LC |
98 | |
99 | \f | |
100 | ;;; | |
101 | ;;; Derivations. | |
102 | ;;; | |
103 | ||
104 | ;; Node in a DAG of build tasks. Each node maps to a derivation, but it's | |
105 | ;; easier to express things this way. | |
106 | (define-record-type <node> | |
107 | (node name modules source dependencies compiled) | |
108 | node? | |
109 | (name node-name) ;string | |
110 | (modules node-modules) ;list of module names | |
111 | (source node-source) ;list of source files | |
112 | (dependencies node-dependencies) ;list of nodes | |
113 | (compiled node-compiled)) ;node -> lowerable object | |
114 | ||
f5db54ea LC |
115 | ;; File mappings are essentially an alist as passed to 'imported-files'. |
116 | (define-record-type <file-mapping> | |
117 | (file-mapping name alist) | |
118 | file-mapping? | |
119 | (name file-mapping-name) | |
120 | (alist file-mapping-alist)) | |
121 | ||
122 | (define-gexp-compiler (file-mapping-compiler (mapping <file-mapping>) | |
123 | system target) | |
124 | ;; Here we use 'imported-files', which can arrange to directly import all | |
125 | ;; the files instead of creating a derivation, when possible. | |
126 | (imported-files (map (match-lambda | |
127 | ((destination (? local-file? file)) | |
128 | (cons destination | |
129 | (local-file-absolute-file-name file))) | |
130 | ((destination source) | |
131 | (cons destination source))) ;silliness | |
132 | (file-mapping-alist mapping)) | |
133 | #:name (file-mapping-name mapping) | |
134 | #:system system)) | |
135 | ||
eaae07ec LC |
136 | (define (node-fold proc init nodes) |
137 | (let loop ((nodes nodes) | |
138 | (visited (setq)) | |
139 | (result init)) | |
140 | (match nodes | |
141 | (() result) | |
142 | ((head tail ...) | |
143 | (if (set-contains? visited head) | |
144 | (loop tail visited result) | |
145 | (loop tail (set-insert head visited) | |
146 | (proc head result))))))) | |
147 | ||
148 | (define (node-modules/recursive nodes) | |
149 | (node-fold (lambda (node modules) | |
150 | (append (node-modules node) modules)) | |
151 | '() | |
152 | nodes)) | |
153 | ||
154 | (define* (closure modules #:optional (except '())) | |
155 | (source-module-closure modules | |
156 | #:select? | |
157 | (match-lambda | |
158 | (('guix 'config) | |
159 | #f) | |
160 | ((and module | |
161 | (or ('guix _ ...) ('gnu _ ...))) | |
162 | (not (member module except))) | |
163 | (rest #f)))) | |
164 | ||
165 | (define module->import | |
166 | ;; Return a file-name/file-like object pair for the specified module and | |
167 | ;; suitable for 'imported-files'. | |
168 | (match-lambda | |
169 | ((module '=> thing) | |
170 | (let ((file (module-name->file-name module))) | |
171 | (list file thing))) | |
172 | (module | |
173 | (let ((file (module-name->file-name module))) | |
174 | (list file | |
175 | (local-file (search-path %load-path file))))))) | |
176 | ||
177 | (define* (scheme-node name modules #:optional (dependencies '()) | |
178 | #:key (extra-modules '()) (extra-files '()) | |
179 | (extensions '()) | |
180 | parallel? guile-for-build) | |
181 | "Return a node that builds the given Scheme MODULES, and depends on | |
182 | DEPENDENCIES (a list of nodes). EXTRA-MODULES is a list of additional modules | |
183 | added to the source, and EXTRA-FILES is a list of additional files. | |
184 | EXTENSIONS is a set of full-blown Guile packages (e.g., 'guile-json') that | |
185 | must be present in the search path." | |
186 | (let* ((modules (append extra-modules | |
187 | (closure modules | |
188 | (node-modules/recursive dependencies)))) | |
189 | (module-files (map module->import modules)) | |
f5db54ea LC |
190 | (source (file-mapping (string-append name "-source") |
191 | (append module-files extra-files)))) | |
eaae07ec | 192 | (node name modules source dependencies |
8031b3fa LC |
193 | (compiled-modules name source |
194 | (map car module-files) | |
eaae07ec LC |
195 | (map node-source dependencies) |
196 | (map node-compiled dependencies) | |
197 | #:extensions extensions | |
198 | #:parallel? parallel? | |
199 | #:guile-for-build guile-for-build)))) | |
200 | ||
201 | (define (file-imports directory sub-directory pred) | |
202 | "List all the files matching PRED under DIRECTORY/SUB-DIRECTORY. Return a | |
203 | list of file-name/file-like objects suitable as inputs to 'imported-files'." | |
204 | (map (lambda (file) | |
205 | (list (string-drop file (+ 1 (string-length directory))) | |
206 | (local-file file #:recursive? #t))) | |
207 | (find-files (string-append directory "/" sub-directory) pred))) | |
208 | ||
6cf502d1 LC |
209 | (define* (file-append* item file #:key (recursive? #t)) |
210 | "Return FILE within ITEM, which may be a file name or a file-like object. | |
211 | When ITEM is a plain file name (a string), simply return a 'local-file' | |
212 | record with the new file name." | |
9f1c3559 LC |
213 | (match item |
214 | ((? string?) | |
215 | ;; This is the optimal case: we return a new "source". Thus, a | |
216 | ;; derivation that depends on this sub-directory does not depend on ITEM | |
217 | ;; itself. | |
6cf502d1 LC |
218 | (local-file (string-append item "/" file) |
219 | #:recursive? recursive?)) | |
9f1c3559 LC |
220 | ;; TODO: Add 'local-file?' case. |
221 | (_ | |
222 | ;; In this case, anything that refers to the result also depends on ITEM, | |
223 | ;; which isn't great. | |
6cf502d1 | 224 | (file-append item "/" file)))) |
9f1c3559 LC |
225 | |
226 | (define* (locale-data source domain | |
227 | #:optional (directory domain)) | |
228 | "Return the locale data from 'po/DIRECTORY' in SOURCE, corresponding to | |
229 | DOMAIN, a gettext domain." | |
230 | (define gettext | |
231 | (module-ref (resolve-interface '(gnu packages gettext)) | |
232 | 'gettext-minimal)) | |
233 | ||
234 | (define build | |
235 | (with-imported-modules '((guix build utils)) | |
236 | #~(begin | |
237 | (use-modules (guix build utils) | |
238 | (srfi srfi-26) | |
239 | (ice-9 match) (ice-9 ftw)) | |
240 | ||
241 | (define po-directory | |
6cf502d1 | 242 | #+(file-append* source (string-append "po/" directory))) |
9f1c3559 LC |
243 | |
244 | (define (compile language) | |
245 | (let ((gmo (string-append #$output "/" language "/LC_MESSAGES/" | |
246 | #$domain ".mo"))) | |
247 | (mkdir-p (dirname gmo)) | |
248 | (invoke #+(file-append gettext "/bin/msgfmt") | |
249 | "-c" "--statistics" "--verbose" | |
250 | "-o" gmo | |
251 | (string-append po-directory "/" language ".po")))) | |
252 | ||
253 | (define (linguas) | |
254 | ;; Return the list of languages. Note: don't read 'LINGUAS' | |
255 | ;; because it contains things like 'en@boldquot' that do not have | |
256 | ;; a corresponding .po file. | |
257 | (map (cut basename <> ".po") | |
258 | (scandir po-directory | |
259 | (cut string-suffix? ".po" <>)))) | |
260 | ||
261 | (for-each compile (linguas))))) | |
262 | ||
263 | (computed-file (string-append "guix-locale-" domain) | |
264 | build)) | |
265 | ||
4554d4c8 LC |
266 | (define (info-manual source) |
267 | "Return the Info manual built from SOURCE." | |
268 | (define texinfo | |
269 | (module-ref (resolve-interface '(gnu packages texinfo)) | |
270 | 'texinfo)) | |
271 | ||
272 | (define graphviz | |
273 | (module-ref (resolve-interface '(gnu packages graphviz)) | |
274 | 'graphviz)) | |
275 | ||
276 | (define documentation | |
6cf502d1 | 277 | (file-append* source "doc")) |
4554d4c8 LC |
278 | |
279 | (define examples | |
6cf502d1 | 280 | (file-append* source "gnu/system/examples")) |
4554d4c8 LC |
281 | |
282 | (define build | |
283 | (with-imported-modules '((guix build utils)) | |
284 | #~(begin | |
285 | (use-modules (guix build utils)) | |
286 | ||
287 | (mkdir #$output) | |
288 | ||
289 | ;; Create 'version.texi'. | |
290 | ;; XXX: Can we use a more meaningful version string yet one that | |
291 | ;; doesn't change at each commit? | |
292 | (call-with-output-file "version.texi" | |
293 | (lambda (port) | |
cbe7387c | 294 | (let ((version "0.0-git")) |
4554d4c8 LC |
295 | (format port " |
296 | @set UPDATED 1 January 1970 | |
297 | @set UPDATED-MONTH January 1970 | |
298 | @set EDITION ~a | |
299 | @set VERSION ~a\n" version version)))) | |
300 | ||
301 | ;; Copy configuration templates that the manual includes. | |
302 | (for-each (lambda (template) | |
303 | (copy-file template | |
304 | (string-append | |
305 | "os-config-" | |
306 | (basename template ".tmpl") | |
307 | ".texi"))) | |
308 | (find-files #$examples "\\.tmpl$")) | |
309 | ||
310 | ;; Build graphs. | |
311 | (mkdir-p (string-append #$output "/images")) | |
312 | (for-each (lambda (dot-file) | |
313 | (invoke #+(file-append graphviz "/bin/dot") | |
314 | "-Tpng" "-Gratio=.9" "-Gnodesep=.005" | |
315 | "-Granksep=.00005" "-Nfontsize=9" | |
316 | "-Nheight=.1" "-Nwidth=.1" | |
317 | "-o" (string-append #$output "/images/" | |
318 | (basename dot-file ".dot") | |
319 | ".png") | |
320 | dot-file)) | |
321 | (find-files (string-append #$documentation "/images") | |
322 | "\\.dot$")) | |
323 | ||
324 | ;; Copy other PNGs. | |
325 | (for-each (lambda (png-file) | |
326 | (install-file png-file | |
327 | (string-append #$output "/images"))) | |
328 | (find-files (string-append #$documentation "/images") | |
329 | "\\.png$")) | |
330 | ||
331 | ;; Finally build the manual. Copy it the Texinfo files to $PWD and | |
332 | ;; add a symlink to the 'images' directory so that 'makeinfo' can | |
333 | ;; see those images and produce image references in the Info output. | |
334 | (copy-recursively #$documentation "." | |
335 | #:log (%make-void-port "w")) | |
336 | (delete-file-recursively "images") | |
337 | (symlink (string-append #$output "/images") "images") | |
338 | ||
339 | (for-each (lambda (texi) | |
340 | (unless (string=? "guix.texi" texi) | |
341 | ;; Create 'version-LL.texi'. | |
342 | (let* ((base (basename texi ".texi")) | |
343 | (dot (string-index base #\.)) | |
344 | (tag (string-drop base (+ 1 dot)))) | |
345 | (symlink "version.texi" | |
346 | (string-append "version-" tag ".texi")))) | |
347 | ||
348 | (invoke #+(file-append texinfo "/bin/makeinfo") | |
349 | texi "-I" #$documentation | |
350 | "-I" "." | |
351 | "-o" (string-append #$output "/" | |
352 | (basename texi ".texi") | |
353 | ".info"))) | |
354 | (cons "guix.texi" | |
355 | (find-files "." "^guix\\.[a-z]{2}\\.texi$")))))) | |
356 | ||
357 | (computed-file "guix-manual" build)) | |
358 | ||
a89faa3f LC |
359 | (define* (guix-command modules #:optional compiled-modules |
360 | #:key source (dependencies '()) | |
8970a886 | 361 | guile (guile-version (effective-version))) |
8a0d9bc8 LC |
362 | "Return the 'guix' command such that it adds MODULES and DEPENDENCIES in its |
363 | load path." | |
f2d0a2cf LC |
364 | (define source-directories |
365 | (map (lambda (package) | |
366 | (file-append package "/share/guile/site/" | |
367 | guile-version)) | |
368 | dependencies)) | |
369 | ||
370 | (define object-directories | |
371 | (map (lambda (package) | |
372 | (file-append package "/lib/guile/" | |
373 | guile-version "/site-ccache")) | |
374 | dependencies)) | |
375 | ||
8a0d9bc8 LC |
376 | (program-file "guix-command" |
377 | #~(begin | |
378 | (set! %load-path | |
f2d0a2cf | 379 | (append (filter file-exists? '#$source-directories) |
8a0d9bc8 LC |
380 | %load-path)) |
381 | ||
382 | (set! %load-compiled-path | |
f2d0a2cf | 383 | (append (filter file-exists? '#$object-directories) |
8a0d9bc8 LC |
384 | %load-compiled-path)) |
385 | ||
386 | (set! %load-path (cons #$modules %load-path)) | |
387 | (set! %load-compiled-path | |
a89faa3f LC |
388 | (cons (or #$compiled-modules #$modules) |
389 | %load-compiled-path)) | |
8a0d9bc8 LC |
390 | |
391 | (let ((guix-main (module-ref (resolve-interface '(guix ui)) | |
392 | 'guix-main))) | |
9f1c3559 LC |
393 | #$(if source |
394 | #~(begin | |
395 | (bindtextdomain "guix" | |
396 | #$(locale-data source "guix")) | |
397 | (bindtextdomain "guix-packages" | |
398 | #$(locale-data source | |
399 | "guix-packages" | |
400 | "packages"))) | |
401 | #t) | |
8a0d9bc8 LC |
402 | |
403 | ;; XXX: It would be more convenient to change it to: | |
404 | ;; (exit (apply guix-main (command-line))) | |
8970a886 LC |
405 | (apply guix-main (command-line)))) |
406 | #:guile guile)) | |
8a0d9bc8 | 407 | |
e3744779 LC |
408 | (define (miscellaneous-files source) |
409 | "Return data files taken from SOURCE." | |
410 | (file-mapping "guix-misc" | |
411 | `(("etc/bash_completion.d/guix" | |
412 | ,(file-append* source "/etc/completion/bash/guix")) | |
413 | ("etc/bash_completion.d/guix-daemon" | |
414 | ,(file-append* source "/etc/completion/bash/guix-daemon")) | |
415 | ("share/zsh/site-functions/_guix" | |
416 | ,(file-append* source "/etc/completion/zsh/_guix")) | |
417 | ("share/fish/vendor_completions.d/guix.fish" | |
418 | ,(file-append* source "/etc/completion/fish/guix.fish")) | |
419 | ("share/guix/hydra.gnu.org.pub" | |
420 | ,(file-append* source | |
421 | "/etc/substitutes/hydra.gnu.org.pub")) | |
422 | ("share/guix/berlin.guixsd.org.pub" | |
423 | ,(file-append* source "/etc/substitutes/berlin.guixsd.org.pub"))))) | |
424 | ||
8a0d9bc8 | 425 | (define* (whole-package name modules dependencies |
9f1c3559 LC |
426 | #:key |
427 | (guile-version (effective-version)) | |
a89faa3f | 428 | compiled-modules |
e3744779 | 429 | info daemon miscellany |
8d3beb3a | 430 | guile |
9f1c3559 LC |
431 | (command (guix-command modules |
432 | #:dependencies dependencies | |
8970a886 | 433 | #:guile guile |
9f1c3559 | 434 | #:guile-version guile-version))) |
8a0d9bc8 | 435 | "Return the whole Guix package NAME that uses MODULES, a derivation of all |
9f1c3559 | 436 | the modules, and DEPENDENCIES, a list of packages depended on. COMMAND is the |
a89faa3f LC |
437 | 'guix' program to use; INFO is the Info manual. When COMPILED-MODULES is |
438 | true, it is linked as 'lib/guile/X.Y/site-ccache'; otherwise, .go files are | |
439 | assumed to be part of MODULES." | |
9f1c3559 LC |
440 | (computed-file name |
441 | (with-imported-modules '((guix build utils)) | |
442 | #~(begin | |
443 | (use-modules (guix build utils)) | |
e3744779 | 444 | |
9f1c3559 LC |
445 | (mkdir-p (string-append #$output "/bin")) |
446 | (symlink #$command | |
447 | (string-append #$output "/bin/guix")) | |
448 | ||
baed9236 LC |
449 | (when #$daemon |
450 | (symlink (string-append #$daemon "/bin/guix-daemon") | |
451 | (string-append #$output "/bin/guix-daemon"))) | |
452 | ||
9f1c3559 LC |
453 | (let ((modules (string-append #$output |
454 | "/share/guile/site/" | |
4554d4c8 LC |
455 | (effective-version))) |
456 | (info #$info)) | |
9f1c3559 | 457 | (mkdir-p (dirname modules)) |
4554d4c8 LC |
458 | (symlink #$modules modules) |
459 | (when info | |
460 | (symlink #$info | |
461 | (string-append #$output | |
a89faa3f LC |
462 | "/share/info")))) |
463 | ||
e3744779 LC |
464 | (when #$miscellany |
465 | (copy-recursively #$miscellany #$output | |
466 | #:log (%make-void-port "w"))) | |
467 | ||
a89faa3f LC |
468 | ;; Object files. |
469 | (when #$compiled-modules | |
470 | (let ((modules (string-append #$output "/lib/guile/" | |
471 | (effective-version) | |
472 | "/site-ccache"))) | |
473 | (mkdir-p (dirname modules)) | |
474 | (symlink #$compiled-modules modules))))))) | |
8a0d9bc8 | 475 | |
eaae07ec | 476 | (define* (compiled-guix source #:key (version %guix-version) |
8a0d9bc8 | 477 | (pull-version 1) |
eaae07ec LC |
478 | (name (string-append "guix-" version)) |
479 | (guile-version (effective-version)) | |
480 | (guile-for-build (guile-for-build guile-version)) | |
eaae07ec LC |
481 | (zlib (specification->package "zlib")) |
482 | (gzip (specification->package "gzip")) | |
483 | (bzip2 (specification->package "bzip2")) | |
484 | (xz (specification->package "xz")) | |
485 | (guix (specification->package "guix"))) | |
486 | "Return a file-like object that contains a compiled Guix." | |
487 | (define guile-json | |
488 | (package-for-guile guile-version | |
489 | "guile-json" | |
eaae07ec LC |
490 | "guile2.0-json")) |
491 | ||
492 | (define guile-ssh | |
493 | (package-for-guile guile-version | |
494 | "guile-ssh" | |
eaae07ec LC |
495 | "guile2.0-ssh")) |
496 | ||
497 | (define guile-git | |
498 | (package-for-guile guile-version | |
499 | "guile-git" | |
500 | "guile2.0-git")) | |
501 | ||
d59e75f3 LC |
502 | (define guile-sqlite3 |
503 | (package-for-guile guile-version | |
504 | "guile-sqlite3" | |
505 | "guile2.0-sqlite3")) | |
506 | ||
ca719424 LC |
507 | (define guile-gcrypt |
508 | (package-for-guile guile-version | |
509 | "guile-gcrypt")) | |
510 | ||
108015df LC |
511 | (define gnutls |
512 | (package-for-guile guile-version | |
513 | "gnutls" "guile2.0-gnutls")) | |
514 | ||
eaae07ec LC |
515 | (define dependencies |
516 | (match (append-map (lambda (package) | |
517 | (cons (list "x" package) | |
e13240f5 | 518 | (package-transitive-propagated-inputs package))) |
ca719424 | 519 | (list guile-gcrypt gnutls guile-git guile-json |
108015df | 520 | guile-ssh guile-sqlite3)) |
eaae07ec LC |
521 | (((labels packages _ ...) ...) |
522 | packages))) | |
523 | ||
524 | (define *core-modules* | |
525 | (scheme-node "guix-core" | |
526 | '((guix) | |
527 | (guix monad-repl) | |
528 | (guix packages) | |
529 | (guix download) | |
530 | (guix discovery) | |
531 | (guix profiles) | |
532 | (guix build-system gnu) | |
533 | (guix build-system trivial) | |
534 | (guix build profiles) | |
535 | (guix build gnu-build-system)) | |
536 | ||
537 | ;; Provide a dummy (guix config) with the default version | |
538 | ;; number, storedir, etc. This is so that "guix-core" is the | |
539 | ;; same across all installations and doesn't need to be | |
540 | ;; rebuilt when the version changes, which in turn means we | |
541 | ;; can have substitutes for it. | |
542 | #:extra-modules | |
ca719424 | 543 | `(((guix config) => ,(make-config.scm))) |
eaae07ec | 544 | |
8292f5a9 LC |
545 | ;; (guix man-db) is needed at build-time by (guix profiles) |
546 | ;; but we don't need to compile it; not compiling it allows | |
547 | ;; us to avoid an extra dependency on guile-gdbm-ffi. | |
548 | #:extra-files | |
3931c761 LC |
549 | `(("guix/man-db.scm" ,(local-file "../guix/man-db.scm")) |
550 | ("guix/store/schema.sql" | |
551 | ,(local-file "../guix/store/schema.sql"))) | |
8292f5a9 | 552 | |
ca719424 | 553 | #:extensions (list guile-gcrypt) |
eaae07ec LC |
554 | #:guile-for-build guile-for-build)) |
555 | ||
556 | (define *extra-modules* | |
557 | (scheme-node "guix-extra" | |
558 | (filter-map (match-lambda | |
559 | (('guix 'scripts _ ..1) #f) | |
8292f5a9 | 560 | (('guix 'man-db) #f) |
eaae07ec LC |
561 | (name name)) |
562 | (scheme-modules* source "guix")) | |
563 | (list *core-modules*) | |
564 | #:extensions dependencies | |
565 | #:guile-for-build guile-for-build)) | |
566 | ||
f2e66663 LC |
567 | (define *core-package-modules* |
568 | (scheme-node "guix-packages-base" | |
eaae07ec | 569 | `((gnu packages) |
f2e66663 | 570 | (gnu packages base)) |
eaae07ec LC |
571 | (list *core-modules* *extra-modules*) |
572 | #:extensions dependencies | |
f2e66663 LC |
573 | |
574 | ;; Add all the non-Scheme files here. We must do it here so | |
575 | ;; that 'search-patches' & co. can find them. Ideally we'd | |
576 | ;; keep them next to the .scm files that use them but it's | |
577 | ;; difficult to do (XXX). | |
578 | #:extra-files | |
eaae07ec LC |
579 | (file-imports source "gnu/packages" |
580 | (lambda (file stat) | |
581 | (and (eq? 'regular (stat:type stat)) | |
582 | (not (string-suffix? ".scm" file)) | |
583 | (not (string-suffix? ".go" file)) | |
584 | (not (string-prefix? ".#" file)) | |
585 | (not (string-suffix? "~" file))))) | |
586 | #:guile-for-build guile-for-build)) | |
587 | ||
f2e66663 LC |
588 | (define *package-modules* |
589 | (scheme-node "guix-packages" | |
590 | (scheme-modules* source "gnu/packages") | |
591 | (list *core-modules* *extra-modules* *core-package-modules*) | |
592 | #:extensions dependencies | |
593 | #:guile-for-build guile-for-build)) | |
594 | ||
eaae07ec LC |
595 | (define *system-modules* |
596 | (scheme-node "guix-system" | |
597 | `((gnu system) | |
598 | (gnu services) | |
599 | ,@(scheme-modules* source "gnu/system") | |
600 | ,@(scheme-modules* source "gnu/services")) | |
f2e66663 LC |
601 | (list *core-package-modules* *package-modules* |
602 | *extra-modules* *core-modules*) | |
eaae07ec LC |
603 | #:extensions dependencies |
604 | #:extra-files | |
1458f768 LC |
605 | (append (file-imports source "gnu/system/examples" |
606 | (const #t)) | |
607 | ||
608 | ;; Build-side code that we don't build. Some of | |
609 | ;; these depend on guile-rsvg, the Shepherd, etc. | |
610 | (file-imports source "gnu/build" (const #t))) | |
eaae07ec LC |
611 | #:guile-for-build |
612 | guile-for-build)) | |
613 | ||
614 | (define *cli-modules* | |
615 | (scheme-node "guix-cli" | |
616 | (scheme-modules* source "/guix/scripts") | |
f2e66663 LC |
617 | (list *core-modules* *extra-modules* |
618 | *core-package-modules* *package-modules* | |
eaae07ec LC |
619 | *system-modules*) |
620 | #:extensions dependencies | |
621 | #:guile-for-build guile-for-build)) | |
622 | ||
623 | (define *config* | |
624 | (scheme-node "guix-config" | |
625 | '() | |
626 | #:extra-modules | |
627 | `(((guix config) | |
ca719424 | 628 | => ,(make-config.scm #:zlib zlib |
eaae07ec LC |
629 | #:gzip gzip |
630 | #:bzip2 bzip2 | |
631 | #:xz xz | |
eaae07ec LC |
632 | #:package-name |
633 | %guix-package-name | |
634 | #:package-version | |
635 | version | |
636 | #:bug-report-address | |
637 | %guix-bug-report-address | |
638 | #:home-page-url | |
639 | %guix-home-page-url))) | |
640 | #:guile-for-build guile-for-build)) | |
641 | ||
a89faa3f | 642 | (define (built-modules node-subset) |
8a0d9bc8 | 643 | (directory-union (string-append name "-modules") |
a89faa3f | 644 | (append-map node-subset |
8a0d9bc8 LC |
645 | |
646 | ;; Note: *CONFIG* comes first so that it | |
647 | ;; overrides the (guix config) module that | |
648 | ;; comes with *CORE-MODULES*. | |
649 | (list *config* | |
650 | *cli-modules* | |
651 | *system-modules* | |
652 | *package-modules* | |
653 | *core-package-modules* | |
654 | *extra-modules* | |
655 | *core-modules*)) | |
656 | ||
657 | ;; Silently choose the first entry upon collision so that | |
658 | ;; we choose *CONFIG*. | |
659 | #:resolve-collision 'first | |
660 | ||
661 | ;; When we do (add-to-store "utils.scm"), "utils.scm" must | |
662 | ;; be a regular file, not a symlink. Thus, arrange so that | |
663 | ;; regular files appear as regular files in the final | |
664 | ;; output. | |
665 | #:copy? #t | |
666 | #:quiet? #t)) | |
667 | ||
668 | ;; Version 0 of 'guix pull' meant we'd just return Scheme modules. | |
669 | ;; Version 1 is when we return the full package. | |
670 | (cond ((= 1 pull-version) | |
671 | ;; The whole package, with a standard file hierarchy. | |
a89faa3f LC |
672 | (let* ((modules (built-modules (compose list node-source))) |
673 | (compiled (built-modules (compose list node-compiled))) | |
674 | (command (guix-command modules compiled | |
675 | #:source source | |
676 | #:dependencies dependencies | |
8970a886 | 677 | #:guile guile-for-build |
a89faa3f LC |
678 | #:guile-version guile-version))) |
679 | (whole-package name modules dependencies | |
680 | #:compiled-modules compiled | |
9f1c3559 | 681 | #:command command |
8970a886 | 682 | #:guile guile-for-build |
baed9236 LC |
683 | |
684 | ;; Include 'guix-daemon'. XXX: Here we inject an | |
685 | ;; older snapshot of guix-daemon, but that's a good | |
686 | ;; enough approximation for now. | |
687 | #:daemon (module-ref (resolve-interface | |
688 | '(gnu packages | |
689 | package-management)) | |
690 | 'guix-daemon) | |
691 | ||
4554d4c8 | 692 | #:info (info-manual source) |
e3744779 | 693 | #:miscellany (miscellaneous-files source) |
9f1c3559 | 694 | #:guile-version guile-version))) |
8a0d9bc8 | 695 | ((= 0 pull-version) |
a89faa3f LC |
696 | ;; Legacy 'guix pull': return the .scm and .go files as one |
697 | ;; directory. | |
698 | (built-modules (lambda (node) | |
699 | (list (node-source node) | |
700 | (node-compiled node))))) | |
8a0d9bc8 LC |
701 | (else |
702 | ;; Unsupported 'guix pull' version. | |
703 | #f))) | |
eaae07ec LC |
704 | |
705 | \f | |
706 | ;;; | |
707 | ;;; Generating (guix config). | |
708 | ;;; | |
709 | ||
710 | (define %dependency-variables | |
711 | ;; (guix config) variables corresponding to dependencies. | |
ca719424 | 712 | '(%libz %xz %gzip %bzip2)) |
eaae07ec LC |
713 | |
714 | (define %persona-variables | |
715 | ;; (guix config) variables that define Guix's persona. | |
716 | '(%guix-package-name | |
717 | %guix-version | |
718 | %guix-bug-report-address | |
719 | %guix-home-page-url)) | |
720 | ||
721 | (define %config-variables | |
45779fa6 LC |
722 | ;; (guix config) variables corresponding to Guix configuration. |
723 | (letrec-syntax ((variables (syntax-rules () | |
724 | ((_) | |
725 | '()) | |
726 | ((_ variable rest ...) | |
727 | (cons `(variable . ,variable) | |
728 | (variables rest ...)))))) | |
7af5c2a2 | 729 | (variables %localstatedir %storedir %sysconfdir %system))) |
eaae07ec | 730 | |
ca719424 | 731 | (define* (make-config.scm #:key zlib gzip xz bzip2 |
eaae07ec LC |
732 | (package-name "GNU Guix") |
733 | (package-version "0") | |
734 | (bug-report-address "bug-guix@gnu.org") | |
735 | (home-page-url "https://gnu.org/s/guix")) | |
736 | ||
737 | ;; Hack so that Geiser is not confused. | |
738 | (define defmod 'define-module) | |
739 | ||
740 | (scheme-file "config.scm" | |
eb72cdf0 | 741 | #~(;; The following expressions get spliced. |
eaae07ec LC |
742 | (#$defmod (guix config) |
743 | #:export (%guix-package-name | |
744 | %guix-version | |
745 | %guix-bug-report-address | |
746 | %guix-home-page-url | |
7af5c2a2 LC |
747 | %store-directory |
748 | %state-directory | |
749 | %store-database-directory | |
750 | %config-directory | |
eaae07ec LC |
751 | %libz |
752 | %gzip | |
753 | %bzip2 | |
e8cb9c01 | 754 | %xz)) |
eaae07ec | 755 | |
63cab418 LC |
756 | #$@(map (match-lambda |
757 | ((name . value) | |
758 | #~(define-public #$name #$value))) | |
759 | %config-variables) | |
760 | ||
7af5c2a2 LC |
761 | (define %store-directory |
762 | (or (and=> (getenv "NIX_STORE_DIR") canonicalize-path) | |
763 | %storedir)) | |
764 | ||
765 | (define %state-directory | |
766 | ;; This must match `NIX_STATE_DIR' as defined in | |
767 | ;; `nix/local.mk'. | |
768 | (or (getenv "NIX_STATE_DIR") | |
769 | (string-append %localstatedir "/guix"))) | |
770 | ||
771 | (define %store-database-directory | |
772 | (or (getenv "NIX_DB_DIR") | |
773 | (string-append %state-directory "/db"))) | |
774 | ||
775 | (define %config-directory | |
776 | ;; This must match `GUIX_CONFIGURATION_DIRECTORY' as | |
777 | ;; defined in `nix/local.mk'. | |
778 | (or (getenv "GUIX_CONFIGURATION_DIRECTORY") | |
779 | (string-append %sysconfdir "/guix"))) | |
780 | ||
63cab418 LC |
781 | (define %guix-package-name #$package-name) |
782 | (define %guix-version #$package-version) | |
783 | (define %guix-bug-report-address #$bug-report-address) | |
784 | (define %guix-home-page-url #$home-page-url) | |
785 | ||
63cab418 LC |
786 | (define %gzip |
787 | #+(and gzip (file-append gzip "/bin/gzip"))) | |
788 | (define %bzip2 | |
789 | #+(and bzip2 (file-append bzip2 "/bin/bzip2"))) | |
790 | (define %xz | |
791 | #+(and xz (file-append xz "/bin/xz"))) | |
792 | ||
63cab418 LC |
793 | (define %libz |
794 | #+(and zlib | |
e8cb9c01 | 795 | (file-append zlib "/lib/libz")))) |
eb72cdf0 LC |
796 | |
797 | ;; Guile 2.0 *requires* the 'define-module' to be at the | |
e8cb9c01 | 798 | ;; top-level or the 'toplevel-ref' in the resulting .go file are |
eb72cdf0 LC |
799 | ;; made relative to a nonexistent anonymous module. |
800 | #:splice? #t)) | |
eaae07ec LC |
801 | |
802 | ||
803 | \f | |
804 | ;;; | |
805 | ;;; Building. | |
806 | ;;; | |
807 | ||
8031b3fa | 808 | (define* (compiled-modules name module-tree module-files |
eaae07ec LC |
809 | #:optional |
810 | (dependencies '()) | |
811 | (dependencies-compiled '()) | |
812 | #:key | |
813 | (extensions '()) ;full-blown Guile packages | |
814 | parallel? | |
815 | guile-for-build) | |
8031b3fa LC |
816 | "Build all the MODULE-FILES from MODULE-TREE. MODULE-FILES must be a list |
817 | like '(\"guix/foo.scm\" \"gnu/bar.scm\") and MODULE-TREE is the directory | |
818 | containing MODULE-FILES and possibly other files as well." | |
eaae07ec LC |
819 | ;; This is a non-monadic, enhanced version of 'compiled-file' from (guix |
820 | ;; gexp). | |
821 | (define build | |
822 | (with-imported-modules (source-module-closure | |
823 | '((guix build compile) | |
824 | (guix build utils))) | |
825 | #~(begin | |
826 | (use-modules (srfi srfi-26) | |
827 | (ice-9 match) | |
828 | (ice-9 format) | |
829 | (ice-9 threads) | |
830 | (guix build compile) | |
831 | (guix build utils)) | |
832 | ||
833 | (define (regular? file) | |
834 | (not (member file '("." "..")))) | |
835 | ||
836 | (define (report-load file total completed) | |
837 | (display #\cr) | |
838 | (format #t | |
839 | "loading...\t~5,1f% of ~d files" ;FIXME: i18n | |
840 | (* 100. (/ completed total)) total) | |
841 | (force-output)) | |
842 | ||
843 | (define (report-compilation file total completed) | |
844 | (display #\cr) | |
845 | (format #t "compiling...\t~5,1f% of ~d files" ;FIXME: i18n | |
846 | (* 100. (/ completed total)) total) | |
847 | (force-output)) | |
848 | ||
8031b3fa LC |
849 | (define (process-directory directory files output) |
850 | ;; Hide compilation warnings. | |
851 | (parameterize ((current-warning-port (%make-void-port "w"))) | |
852 | (compile-files directory #$output files | |
853 | #:workers (parallel-job-count) | |
854 | #:report-load report-load | |
855 | #:report-compilation report-compilation))) | |
eaae07ec LC |
856 | |
857 | (setvbuf (current-output-port) _IONBF) | |
858 | (setvbuf (current-error-port) _IONBF) | |
859 | ||
860 | (set! %load-path (cons #+module-tree %load-path)) | |
861 | (set! %load-path | |
862 | (append '#+dependencies | |
863 | (map (lambda (extension) | |
864 | (string-append extension "/share/guile/site/" | |
865 | (effective-version))) | |
866 | '#+extensions) | |
867 | %load-path)) | |
868 | ||
869 | (set! %load-compiled-path | |
870 | (append '#+dependencies-compiled | |
871 | (map (lambda (extension) | |
872 | (string-append extension "/lib/guile/" | |
873 | (effective-version) | |
874 | "/site-ccache")) | |
875 | '#+extensions) | |
876 | %load-compiled-path)) | |
877 | ||
878 | ;; Load the compiler modules upfront. | |
879 | (compile #f) | |
880 | ||
881 | (mkdir #$output) | |
882 | (chdir #+module-tree) | |
8031b3fa | 883 | (process-directory "." '#+module-files #$output) |
69447b63 | 884 | (newline)))) |
eaae07ec LC |
885 | |
886 | (computed-file name build | |
887 | #:guile guile-for-build | |
888 | #:options | |
889 | `(#:local-build? #f ;allow substitutes | |
890 | ||
891 | ;; Don't annoy people about _IONBF deprecation. | |
54be2b4d LC |
892 | ;; Initialize 'terminal-width' in (system repl debug) |
893 | ;; to a large-enough value to make backtrace more | |
894 | ;; verbose. | |
895 | #:env-vars (("GUILE_WARN_DEPRECATED" . "no") | |
896 | ("COLUMNS" . "200"))))) | |
eaae07ec LC |
897 | |
898 | \f | |
899 | ;;; | |
900 | ;;; Building. | |
901 | ;;; | |
902 | ||
903 | (define (guile-for-build version) | |
904 | "Return a derivation for Guile 2.0 or 2.2, whichever matches the currently | |
905 | running Guile." | |
906 | (define canonical-package ;soft reference | |
907 | (module-ref (resolve-interface '(gnu packages base)) | |
908 | 'canonical-package)) | |
909 | ||
910 | (match version | |
911 | ("2.2.2" | |
912 | ;; Gross hack to avoid ABI incompatibilities (see | |
913 | ;; <https://bugs.gnu.org/29570>.) | |
914 | (module-ref (resolve-interface '(gnu packages guile)) | |
915 | 'guile-2.2.2)) | |
916 | ("2.2" | |
084f64cb LC |
917 | ;; Use the latest version, which has fixes for |
918 | ;; <https://bugs.gnu.org/30602> and VM stack-marking issues. | |
eaae07ec | 919 | (canonical-package (module-ref (resolve-interface '(gnu packages guile)) |
084f64cb | 920 | 'guile-2.2.4))) |
eaae07ec | 921 | ("2.0" |
e69dd844 LC |
922 | (module-ref (resolve-interface '(gnu packages guile)) |
923 | 'guile-2.0)))) | |
eaae07ec LC |
924 | |
925 | (define* (guix-derivation source version | |
8a0d9bc8 LC |
926 | #:optional (guile-version (effective-version)) |
927 | #:key (pull-version 0)) | |
eaae07ec | 928 | "Return, as a monadic value, the derivation to build the Guix from SOURCE |
8a0d9bc8 LC |
929 | for GUILE-VERSION. Use VERSION as the version string. PULL-VERSION specifies |
930 | the version of the 'guix pull' protocol. Return #f if this PULL-VERSION value | |
931 | is not supported." | |
eaae07ec LC |
932 | (define (shorten version) |
933 | (if (and (string-every char-set:hex-digit version) | |
934 | (> (string-length version) 9)) | |
935 | (string-take version 9) ;Git commit | |
936 | version)) | |
937 | ||
938 | (define guile | |
099bb017 LC |
939 | ;; When PULL-VERSION >= 1, produce a self-contained Guix and use Guile 2.2 |
940 | ;; unconditionally. | |
941 | (guile-for-build (if (>= pull-version 1) | |
942 | "2.2" | |
943 | guile-version))) | |
eaae07ec LC |
944 | |
945 | (mbegin %store-monad | |
946 | (set-guile-for-build guile) | |
8a0d9bc8 LC |
947 | (let ((guix (compiled-guix source |
948 | #:version version | |
949 | #:name (string-append "guix-" | |
950 | (shorten version)) | |
951 | #:pull-version pull-version | |
099bb017 LC |
952 | #:guile-version (if (>= pull-version 1) |
953 | "2.2" | |
954 | (match guile-version | |
955 | ("2.2.2" "2.2") | |
956 | (version version))) | |
8a0d9bc8 LC |
957 | #:guile-for-build guile))) |
958 | (if guix | |
959 | (lower-object guix) | |
960 | (return #f))))) |