Commit | Line | Data |
---|---|---|
f81ac34d | 1 | ;;; GNU Guix --- Functional package management for GNU |
838ba73d | 2 | ;;; Copyright © 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> |
f81ac34d LC |
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 (build-self) | |
f81ac34d | 20 | #:use-module (srfi srfi-1) |
b006ba50 | 21 | #:use-module (srfi srfi-19) |
5f93d970 | 22 | #:use-module (srfi srfi-26) |
838ba73d | 23 | #:use-module (ice-9 match) |
f81ac34d LC |
24 | #:export (build)) |
25 | ||
26 | ;;; Commentary: | |
27 | ;;; | |
28 | ;;; When loaded, this module returns a monadic procedure of at least one | |
29 | ;;; argument: the source tree to build. It returns a derivation that | |
30 | ;;; builds it. | |
31 | ;;; | |
f81ac34d LC |
32 | ;;; Code: |
33 | ||
5f93d970 LC |
34 | ;; Use our very own Guix modules. |
35 | (eval-when (compile load eval) | |
f81ac34d LC |
36 | (and=> (assoc-ref (current-source-location) 'filename) |
37 | (lambda (file) | |
5f93d970 LC |
38 | (let ((dir (string-append (dirname file) "/.."))) |
39 | (set! %load-path (cons dir %load-path)))))) | |
b006ba50 LC |
40 | |
41 | (define (date-version-string) | |
42 | "Return the current date and hour in UTC timezone, for use as a poor | |
43 | person's version identifier." | |
5f93d970 | 44 | ;; XXX: Last resort when the Git commit id is missing. |
b006ba50 LC |
45 | (date->string (current-date 0) "~Y~m~d.~H")) |
46 | ||
5f93d970 LC |
47 | (define-syntax parameterize* |
48 | (syntax-rules () | |
49 | "Like 'parameterize' but for regular variables (!)." | |
50 | ((_ ((var value) rest ...) body ...) | |
51 | (let ((old var) | |
52 | (new value)) | |
53 | (dynamic-wind | |
54 | (lambda () | |
55 | (set! var new)) | |
56 | (lambda () | |
57 | (parameterize* (rest ...) body ...)) | |
58 | (lambda () | |
59 | (set! var old))))) | |
60 | ((_ () body ...) | |
61 | (begin body ...)))) | |
62 | ||
63 | (define (pure-load-compiled-path) | |
64 | "Return %LOAD-COMPILED-PATH minus the directories containing .go files from | |
65 | Guix." | |
66 | (define (purify path) | |
67 | (fold-right delete path | |
68 | (filter-map (lambda (file) | |
69 | (and=> (search-path path file) dirname)) | |
70 | '("guix.go" "gnu.go")))) | |
71 | ||
72 | (let loop ((path %load-compiled-path)) | |
73 | (let ((next (purify path))) | |
74 | (if (equal? next path) | |
75 | path | |
76 | (loop next))))) | |
838ba73d | 77 | |
f81ac34d | 78 | ;; The procedure below is our return value. |
b006ba50 LC |
79 | (define* (build source |
80 | #:key verbose? (version (date-version-string)) | |
f81ac34d LC |
81 | #:allow-other-keys |
82 | #:rest rest) | |
83 | "Return a derivation that unpacks SOURCE into STORE and compiles Scheme | |
84 | files." | |
5f93d970 LC |
85 | ;; Start by jumping into the target Guix so that we have access to the |
86 | ;; latest packages and APIs. | |
87 | ;; | |
88 | ;; Our checkout in the store has mtime set to the epoch, and thus .go | |
89 | ;; files look newer, even though they may not correspond. | |
90 | (parameterize* ((%load-should-auto-compile #f) | |
91 | (%fresh-auto-compile #f) | |
92 | ||
93 | ;; Work around <https://bugs.gnu.org/29226>. | |
94 | (%load-compiled-path (pure-load-compiled-path))) | |
95 | ;; FIXME: This is currently too expensive notably because it involves | |
96 | ;; compiling a number of the big package files such as perl.scm, which | |
97 | ;; takes lots of time and memory as of Guile 2.2.2. | |
98 | ;; | |
99 | ;; (let ((reload-guix (module-ref (resolve-interface '(guix self)) | |
100 | ;; 'reload-guix))) | |
101 | ;; (reload-guix)) ;cross fingers! | |
102 | ||
103 | (let ((guix-derivation (module-ref (resolve-interface '(guix self)) | |
104 | 'guix-derivation))) | |
105 | (guix-derivation source version)))) | |
f81ac34d LC |
106 | |
107 | ;; This file is loaded by 'guix pull'; return it the build procedure. | |
108 | build | |
109 | ||
f81ac34d | 110 | ;;; build-self.scm ends here |