Commit | Line | Data |
---|---|---|
2a3b1b32 | 1 | ;;; GNU Guix --- Functional package management for GNU |
abeb54c0 | 2 | ;;; Copyright © 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
2a3b1b32 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 (guix build guile-build-system) | |
20 | #:use-module ((guix build gnu-build-system) #:prefix gnu:) | |
21 | #:use-module (guix build utils) | |
30eb7383 | 22 | #:use-module (srfi srfi-1) |
2a3b1b32 LC |
23 | #:use-module (srfi srfi-26) |
24 | #:use-module (ice-9 match) | |
25 | #:use-module (ice-9 popen) | |
26 | #:use-module (ice-9 rdelim) | |
30eb7383 | 27 | #:use-module (ice-9 regex) |
e006f749 | 28 | #:use-module (ice-9 format) |
2a3b1b32 LC |
29 | #:use-module (guix build utils) |
30 | #:export (target-guile-effective-version | |
31 | %standard-phases | |
32 | guile-build)) | |
33 | ||
34 | (define* (target-guile-effective-version #:optional guile) | |
35 | "Return the effective version of GUILE or whichever 'guile' is in $PATH. | |
36 | Return #false if it cannot be determined." | |
37 | (let* ((pipe (open-pipe* OPEN_READ | |
38 | (if guile | |
39 | (string-append guile "/bin/guile") | |
40 | "guile") | |
41 | "-c" "(display (effective-version))")) | |
42 | (line (read-line pipe))) | |
43 | (and (zero? (close-pipe pipe)) | |
44 | (string? line) | |
45 | line))) | |
46 | ||
47 | (define (file-sans-extension file) ;TODO: factorize | |
48 | "Return the substring of FILE without its extension, if any." | |
49 | (let ((dot (string-rindex file #\.))) | |
50 | (if dot | |
51 | (substring file 0 dot) | |
52 | file))) | |
53 | ||
54 | (define %scheme-file-regexp | |
55 | ;; Regexp to match Scheme files. | |
56 | "\\.(scm|sls)$") | |
57 | ||
58 | (define %documentation-file-regexp | |
59 | ;; Regexp to match README files and the likes. | |
60 | "^(README.*|.*\\.html|.*\\.org|.*\\.md)$") | |
61 | ||
62 | (define* (set-locale-path #:key inputs native-inputs | |
63 | #:allow-other-keys) | |
64 | "Set 'GUIX_LOCPATH'." | |
65 | (match (assoc-ref (or native-inputs inputs) "locales") | |
66 | (#f #t) | |
67 | (locales | |
68 | (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale")) | |
69 | #t))) | |
70 | ||
3fdb9a37 CB |
71 | (define* (invoke-each commands |
72 | #:key (max-processes (current-processor-count)) | |
73 | report-progress) | |
74 | "Run each command in COMMANDS in a separate process, using up to | |
75 | MAX-PROCESSES processes in parallel. Call REPORT-PROGRESS at each step. | |
76 | Raise an error if one of the processes exit with non-zero." | |
77 | (define total | |
78 | (length commands)) | |
79 | ||
abeb54c0 LC |
80 | (define processes |
81 | (make-hash-table)) | |
82 | ||
3fdb9a37 CB |
83 | (define (wait-for-one-process) |
84 | (match (waitpid WAIT_ANY) | |
abeb54c0 LC |
85 | ((pid . status) |
86 | (let ((command (hashv-ref processes pid))) | |
87 | (hashv-remove! processes command) | |
88 | (unless (zero? (status:exit-val status)) | |
89 | (format (current-error-port) | |
90 | "process '~{~a ~}' failed with status ~a~%" | |
91 | command status) | |
92 | (exit 1)))))) | |
3fdb9a37 CB |
93 | |
94 | (define (fork-and-run-command command) | |
95 | (match (primitive-fork) | |
96 | (0 | |
97 | (dynamic-wind | |
98 | (const #t) | |
99 | (lambda () | |
100 | (apply execlp command)) | |
101 | (lambda () | |
102 | (primitive-exit 127)))) | |
103 | (pid | |
abeb54c0 | 104 | (hashv-set! processes pid command) |
3fdb9a37 CB |
105 | #t))) |
106 | ||
107 | (let loop ((commands commands) | |
108 | (running 0) | |
109 | (completed 0)) | |
110 | (match commands | |
111 | (() | |
112 | (or (zero? running) | |
113 | (let ((running (- running 1)) | |
114 | (completed (+ completed 1))) | |
115 | (wait-for-one-process) | |
116 | (report-progress total completed) | |
117 | (loop commands running completed)))) | |
118 | ((command . rest) | |
119 | (if (< running max-processes) | |
120 | (let ((running (+ 1 running))) | |
121 | (fork-and-run-command command) | |
122 | (loop rest running completed)) | |
123 | (let ((running (- running 1)) | |
124 | (completed (+ completed 1))) | |
125 | (wait-for-one-process) | |
126 | (report-progress total completed) | |
127 | (loop commands running completed))))))) | |
128 | ||
129 | (define* (report-build-progress total completed | |
130 | #:optional (log-port (current-error-port))) | |
131 | "Report that COMPLETED out of TOTAL files have been completed." | |
e006f749 LC |
132 | (format log-port "[~2d/~2d] Compiling...~%" |
133 | completed total) | |
3fdb9a37 CB |
134 | (force-output log-port)) |
135 | ||
2a3b1b32 LC |
136 | (define* (build #:key outputs inputs native-inputs |
137 | (source-directory ".") | |
138 | (compile-flags '()) | |
139 | (scheme-file-regexp %scheme-file-regexp) | |
30eb7383 | 140 | (not-compiled-file-regexp #f) |
2a3b1b32 LC |
141 | target |
142 | #:allow-other-keys) | |
30eb7383 LC |
143 | "Build files in SOURCE-DIRECTORY that match SCHEME-FILE-REGEXP. Files |
144 | matching NOT-COMPILED-FILE-REGEXP, if true, are not compiled but are | |
145 | installed; this is useful for files that are meant to be included." | |
2a3b1b32 LC |
146 | (let* ((out (assoc-ref outputs "out")) |
147 | (guile (assoc-ref (or native-inputs inputs) "guile")) | |
148 | (effective (target-guile-effective-version guile)) | |
149 | (module-dir (string-append out "/share/guile/site/" | |
150 | effective)) | |
151 | (go-dir (string-append out "/lib/guile/" | |
152 | effective "/site-ccache/")) | |
153 | (guild (string-append guile "/bin/guild")) | |
154 | (flags (if target | |
155 | (cons (string-append "--target=" target) | |
156 | compile-flags) | |
157 | compile-flags))) | |
158 | (if target | |
159 | (format #t "Cross-compiling for '~a' with Guile ~a...~%" | |
160 | target effective) | |
161 | (format #t "Compiling with Guile ~a...~%" effective)) | |
162 | (format #t "compile flags: ~s~%" flags) | |
163 | ||
164 | ;; Make installation directories. | |
165 | (mkdir-p module-dir) | |
166 | (mkdir-p go-dir) | |
167 | ||
168 | ;; Compile .scm files and install. | |
169 | (setenv "GUILE_AUTO_COMPILE" "0") | |
170 | (setenv "GUILE_LOAD_COMPILED_PATH" | |
171 | (string-append go-dir | |
172 | (match (getenv "GUILE_LOAD_COMPILED_PATH") | |
173 | (#f "") | |
174 | (path (string-append ":" path))))) | |
3fdb9a37 CB |
175 | |
176 | (let ((source-files | |
177 | (with-directory-excursion source-directory | |
178 | (find-files "." scheme-file-regexp)))) | |
179 | (invoke-each | |
30eb7383 LC |
180 | (filter-map (lambda (file) |
181 | (and (or (not not-compiled-file-regexp) | |
182 | (not (string-match not-compiled-file-regexp | |
183 | file))) | |
184 | (cons* guild | |
185 | "guild" "compile" | |
186 | "-L" source-directory | |
187 | "-o" (string-append go-dir | |
188 | (file-sans-extension file) | |
189 | ".go") | |
190 | (string-append source-directory "/" file) | |
191 | flags))) | |
192 | source-files) | |
3fdb9a37 CB |
193 | #:max-processes (parallel-job-count) |
194 | #:report-progress report-build-progress) | |
195 | ||
196 | (for-each | |
197 | (lambda (file) | |
198 | (install-file (string-append source-directory "/" file) | |
199 | (string-append module-dir | |
200 | "/" (dirname file)))) | |
201 | source-files)) | |
2a3b1b32 LC |
202 | #t)) |
203 | ||
204 | (define* (install-documentation #:key outputs | |
205 | (documentation-file-regexp | |
206 | %documentation-file-regexp) | |
207 | #:allow-other-keys) | |
208 | "Install files that mactch DOCUMENTATION-FILE-REGEXP." | |
209 | (let* ((out (assoc-ref outputs "out")) | |
210 | (doc (string-append out "/share/doc/" | |
211 | (strip-store-file-name out)))) | |
212 | (for-each (cut install-file <> doc) | |
213 | (find-files "." documentation-file-regexp)) | |
214 | #t)) | |
215 | ||
216 | (define %standard-phases | |
217 | (modify-phases gnu:%standard-phases | |
218 | (delete 'bootstrap) | |
219 | (delete 'configure) | |
220 | (add-before 'install-locale 'set-locale-path | |
221 | set-locale-path) | |
222 | (replace 'build build) | |
223 | (add-after 'build 'install-documentation | |
224 | install-documentation) | |
225 | (delete 'check) | |
226 | (delete 'strip) | |
227 | (delete 'validate-runpath) | |
228 | (delete 'install))) | |
229 | ||
230 | (define* (guile-build #:key (phases %standard-phases) | |
231 | #:allow-other-keys #:rest args) | |
232 | "Build the given Guile package, applying all of PHASES in order." | |
233 | (apply gnu:gnu-build #:phases phases args)) |