Commit | Line | Data |
---|---|---|
a1b30f99 | 1 | ;;; GNU Guix --- Functional package management for GNU |
bc389c20 | 2 | ;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> |
a1b30f99 AP |
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 lisp-utils) | |
20 | #:use-module (ice-9 format) | |
35189728 | 21 | #:use-module (ice-9 hash-table) |
a1b30f99 AP |
22 | #:use-module (ice-9 match) |
23 | #:use-module (ice-9 regex) | |
24 | #:use-module (srfi srfi-1) | |
25 | #:use-module (srfi srfi-26) | |
26 | #:use-module (guix build utils) | |
27 | #:export (%lisp | |
b4c9f0c5 | 28 | %lisp-type |
bc389c20 | 29 | %source-install-prefix |
a1b30f99 AP |
30 | lisp-eval-program |
31 | compile-system | |
32 | test-system | |
33 | replace-escaped-macros | |
34 | generate-executable-wrapper-system | |
35 | generate-executable-entry-point | |
36 | generate-executable-for-system | |
b4c9f0c5 | 37 | %bundle-install-prefix |
a1b30f99 | 38 | bundle-asd-file |
a1b30f99 AP |
39 | wrap-output-translations |
40 | prepend-to-source-registry | |
41 | build-program | |
35189728 | 42 | build-image |
40f56176 AP |
43 | make-asd-file |
44 | valid-char-set | |
4209c31b AP |
45 | normalize-string |
46 | library-output)) | |
a1b30f99 AP |
47 | |
48 | ;;; Commentary: | |
49 | ;;; | |
50 | ;;; Tools to evaluate lisp programs within a lisp session, generate wrapper | |
51 | ;;; systems for executables. Compile, test, and produce images for systems and | |
52 | ;;; programs, and link them with their dependencies. | |
53 | ;;; | |
54 | ;;; Code: | |
55 | ||
56 | (define %lisp | |
57 | ;; File name of the Lisp compiler. | |
58 | (make-parameter "lisp")) | |
59 | ||
b4c9f0c5 AP |
60 | (define %lisp-type |
61 | ;; String representing the class of implementation being used. | |
62 | (make-parameter "lisp")) | |
63 | ||
bc389c20 AP |
64 | ;; The common parent for Lisp source files, as will as the symbolic |
65 | ;; link farm for system definition (.asd) files. | |
66 | (define %source-install-prefix "/share/common-lisp") | |
a1b30f99 | 67 | |
b4c9f0c5 AP |
68 | (define (%bundle-install-prefix) |
69 | (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems")) | |
a1b30f99 | 70 | |
4209c31b AP |
71 | (define (library-output outputs) |
72 | "If a `lib' output exists, build things there. Otherwise use `out'." | |
73 | (or (assoc-ref outputs "lib") (assoc-ref outputs "out"))) | |
74 | ||
40f56176 AP |
75 | ;; See nix/libstore/store-api.cc#checkStoreName. |
76 | (define valid-char-set | |
77 | (string->char-set | |
78 | "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?=")) | |
79 | ||
80 | (define (normalize-string str) | |
81 | "Replace invalid characters in STR with a hyphen." | |
82 | (string-join (string-tokenize str valid-char-set) "-")) | |
83 | ||
7b6b7cdc AP |
84 | (define (normalize-dependency dependency) |
85 | "Normalize the name of DEPENDENCY. Handles dependency definitions of the | |
86 | dependency-def form described by | |
a7b75196 AP |
87 | <https://common-lisp.net/project/asdf/asdf.html#The-defsystem-grammar>. |
88 | Assume that any symbols in DEPENDENCY will be in upper-case." | |
7b6b7cdc | 89 | (match dependency |
a7b75196 | 90 | ((':VERSION name rest ...) |
7b6b7cdc | 91 | `(:version ,(normalize-string name) ,@rest)) |
a7b75196 | 92 | ((':FEATURE feature-specification dependency-specification) |
7b6b7cdc AP |
93 | `(:feature |
94 | ,feature-specification | |
95 | ,(normalize-dependency dependency-specification))) | |
96 | ((? string? name) (normalize-string name)) | |
97 | (require-specification require-specification))) | |
98 | ||
b4c9f0c5 | 99 | (define (inputs->asd-file-map inputs) |
35189728 AP |
100 | "Produce a hash table of the form (system . asd-file), where system is the |
101 | name of an ASD system, and asd-file is the full path to its definition." | |
102 | (alist->hash-table | |
103 | (filter-map | |
104 | (match-lambda | |
105 | ((_ . path) | |
b4c9f0c5 | 106 | (let ((prefix (string-append path (%bundle-install-prefix)))) |
35189728 AP |
107 | (and (directory-exists? prefix) |
108 | (match (find-files prefix "\\.asd$") | |
109 | ((asd-file) | |
110 | (cons | |
111 | (string-drop-right (basename asd-file) 4) ; drop ".asd" | |
112 | asd-file)) | |
113 | (_ #f)))))) | |
114 | inputs))) | |
115 | ||
a1b30f99 AP |
116 | (define (wrap-output-translations translations) |
117 | `(:output-translations | |
118 | ,@translations | |
119 | :inherit-configuration)) | |
120 | ||
b4c9f0c5 | 121 | (define (lisp-eval-program program) |
a1b30f99 | 122 | "Evaluate PROGRAM with a given LISP implementation." |
29a3ffb4 AP |
123 | (define invocation (lisp-invocation program)) |
124 | (format #t "Invoking ~a: ~{~s ~}~%" (%lisp-type) invocation) | |
e831a166 | 125 | (apply invoke invocation)) |
a1b30f99 | 126 | |
b9afcb9e AP |
127 | (define (spread-statements program argument-name) |
128 | "Return a list with the statements from PROGRAM spread between | |
129 | ARGUMENT-NAME, a string representing the argument a lisp implementation uses | |
130 | to accept statements to be evaluated before starting." | |
131 | (append-map (lambda (statement) | |
132 | (list argument-name (format #f "~S" statement))) | |
133 | program)) | |
134 | ||
135 | (define (lisp-invocation program) | |
a1b30f99 AP |
136 | "Return a list of arguments for system* determining how to invoke LISP |
137 | with PROGRAM." | |
b4c9f0c5 | 138 | (match (%lisp-type) |
b9afcb9e AP |
139 | ("sbcl" `(,(%lisp) "--non-interactive" |
140 | ,@(spread-statements program "--eval"))) | |
141 | ("ecl" `(,(%lisp) | |
142 | ,@(spread-statements program "--eval") | |
143 | "--eval" "(quit)")) | |
35189728 | 144 | (_ (error "The LISP provided is not supported at this time.")))) |
a1b30f99 AP |
145 | |
146 | (define (asdf-load-all systems) | |
147 | (map (lambda (system) | |
b9afcb9e | 148 | `(asdf:load-system ,system)) |
a1b30f99 AP |
149 | systems)) |
150 | ||
b4c9f0c5 | 151 | (define (compile-system system asd-file) |
a1b30f99 | 152 | "Use a lisp implementation to compile SYSTEM using asdf. Load ASD-FILE |
0186a463 | 153 | first." |
b4c9f0c5 | 154 | (lisp-eval-program |
b9afcb9e | 155 | `((require :asdf) |
5f6908d6 | 156 | (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system)) |
b9afcb9e | 157 | (asdf:operate 'asdf:compile-bundle-op ,system)))) |
b4c9f0c5 AP |
158 | |
159 | (define (system-dependencies system asd-file) | |
35189728 | 160 | "Return the dependencies of SYSTEM, as reported by |
0186a463 | 161 | asdf:system-depends-on. First load the system's ASD-FILE." |
35189728 AP |
162 | (define deps-file ".deps.sexp") |
163 | (define program | |
b9afcb9e | 164 | `((require :asdf) |
5f6908d6 | 165 | (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system)) |
35189728 AP |
166 | (with-open-file |
167 | (stream ,deps-file :direction :output) | |
168 | (format stream | |
169 | "~s~%" | |
b9afcb9e AP |
170 | (asdf:system-depends-on |
171 | (asdf:find-system ,system)))))) | |
35189728 AP |
172 | |
173 | (dynamic-wind | |
174 | (lambda _ | |
b4c9f0c5 | 175 | (lisp-eval-program program)) |
35189728 AP |
176 | (lambda _ |
177 | (call-with-input-file deps-file read)) | |
178 | (lambda _ | |
179 | (when (file-exists? deps-file) | |
180 | (delete-file deps-file))))) | |
181 | ||
b4c9f0c5 | 182 | (define (compiled-system system) |
40f56176 AP |
183 | (let ((system (basename system))) ; this is how asdf handles slashes |
184 | (match (%lisp-type) | |
185 | ("sbcl" (string-append system "--system")) | |
186 | (_ system)))) | |
35189728 | 187 | |
b4c9f0c5 | 188 | (define* (generate-system-definition system |
5a08660e | 189 | #:key version dependencies component?) |
35189728 | 190 | `(asdf:defsystem |
40f56176 | 191 | ,(normalize-string system) |
5a08660e PN |
192 | ,@(if component? |
193 | '(:class asdf/bundle:prebuilt-system) | |
194 | '()) | |
35189728 AP |
195 | :version ,version |
196 | :depends-on ,dependencies | |
5a08660e PN |
197 | ,@(if component? |
198 | `(:components ((:compiled-file ,(compiled-system system)))) | |
199 | '()) | |
b4c9f0c5 | 200 | ,@(if (string=? "ecl" (%lisp-type)) |
35189728 AP |
201 | `(:lib ,(string-append system ".a")) |
202 | '()))) | |
203 | ||
0383afa0 AP |
204 | (define (test-system system asd-file test-asd-file) |
205 | "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first. | |
206 | Also load TEST-ASD-FILE if necessary." | |
b4c9f0c5 | 207 | (lisp-eval-program |
b9afcb9e | 208 | `((require :asdf) |
5f6908d6 AP |
209 | (asdf:load-asd (truename ,asd-file) :name ,(normalize-string system)) |
210 | ,@(if test-asd-file | |
211 | `((asdf:load-asd (truename ,test-asd-file))) | |
212 | ;; Try some likely files. | |
213 | (map (lambda (file) | |
214 | `(when (uiop:file-exists-p ,file) | |
215 | (asdf:load-asd (truename ,file)))) | |
216 | (list | |
217 | (string-append system "-tests.asd") | |
218 | (string-append system "-test.asd") | |
219 | "tests.asd" | |
220 | "test.asd"))) | |
b9afcb9e | 221 | (asdf:test-system ,system)))) |
a1b30f99 AP |
222 | |
223 | (define (string->lisp-keyword . strings) | |
224 | "Return a lisp keyword for the concatenation of STRINGS." | |
225 | (string->symbol (apply string-append ":" strings))) | |
226 | ||
01e38cc4 | 227 | (define* (generate-executable-for-system type system #:key compress?) |
b9afcb9e AP |
228 | "Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or |
229 | 'asdf:program-op. The latter will always be standalone. Depends on having | |
230 | created a \"SYSTEM-exec\" system which contains the entry program." | |
a1b30f99 | 231 | (lisp-eval-program |
b9afcb9e | 232 | `((require :asdf) |
01e38cc4 PN |
233 | ;; Only SBCL supports compression as of 2019-09-02. |
234 | ,(if (and compress? (string=? (%lisp-type) "sbcl")) | |
235 | '(defmethod asdf:perform ((o asdf:image-op) (c asdf:system)) | |
236 | (uiop:dump-image (asdf:output-file o c) | |
237 | :executable t | |
238 | :compression t)) | |
239 | '()) | |
b9afcb9e | 240 | (asdf:operate ',type ,(string-append system "-exec"))))) |
a1b30f99 AP |
241 | |
242 | (define (generate-executable-wrapper-system system dependencies) | |
243 | "Generates a system which can be used by asdf to produce an image or program | |
244 | inside the current directory. The image or program will contain | |
245 | DEPENDENCIES." | |
246 | (with-output-to-file (string-append system "-exec.asd") | |
247 | (lambda _ | |
248 | (format #t "~y~%" | |
249 | `(defsystem ,(string->lisp-keyword system "-exec") | |
250 | :entry-point ,(string-append system "-exec:main") | |
251 | :depends-on (:uiop | |
252 | ,@(map string->lisp-keyword | |
253 | dependencies)) | |
254 | :components ((:file ,(string-append system "-exec")))))))) | |
255 | ||
256 | (define (generate-executable-entry-point system entry-program) | |
257 | "Generates an entry point program from the list of lisp statements | |
258 | ENTRY-PROGRAM for SYSTEM within the current directory." | |
259 | (with-output-to-file (string-append system "-exec.lisp") | |
260 | (lambda _ | |
261 | (let ((system (string->lisp-keyword system "-exec"))) | |
262 | (format #t "~{~y~%~%~}" | |
263 | `((defpackage ,system | |
264 | (:use :cl) | |
265 | (:export :main)) | |
266 | ||
267 | (in-package ,system) | |
268 | ||
269 | (defun main () | |
270 | (let ((arguments uiop:*command-line-arguments*)) | |
271 | (declare (ignorable arguments)) | |
272 | ,@entry-program)))))))) | |
273 | ||
b4c9f0c5 | 274 | (define (generate-dependency-links registry system) |
35189728 AP |
275 | "Creates a program which populates asdf's source registry from REGISTRY, an |
276 | alist of dependency names to corresponding asd files. This allows the system | |
277 | to locate its dependent systems." | |
278 | `(progn | |
279 | (asdf/source-registry:ensure-source-registry) | |
280 | ,@(map (match-lambda | |
281 | ((name . asd-file) | |
282 | `(setf | |
283 | (gethash ,name | |
284 | asdf/source-registry:*source-registry*) | |
285 | ,(string->symbol "#p") | |
286 | ,asd-file))) | |
287 | registry))) | |
288 | ||
289 | (define* (make-asd-file asd-file | |
b4c9f0c5 | 290 | #:key system version inputs |
35189728 AP |
291 | (system-asd-file #f)) |
292 | "Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the | |
293 | system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS." | |
294 | (define dependencies | |
40f56176 AP |
295 | (let ((deps |
296 | (system-dependencies system system-asd-file))) | |
297 | (if (eq? 'NIL deps) | |
298 | '() | |
7b6b7cdc | 299 | (map normalize-dependency deps)))) |
35189728 AP |
300 | |
301 | (define lisp-input-map | |
b4c9f0c5 | 302 | (inputs->asd-file-map inputs)) |
35189728 | 303 | |
7b6b7cdc AP |
304 | (define dependency-name |
305 | (match-lambda | |
306 | ((':version name _ ...) name) | |
307 | ((':feature _ dependency-specification) | |
308 | (dependency-name dependency-specification)) | |
309 | ((? string? name) name) | |
310 | (_ #f))) | |
311 | ||
35189728 AP |
312 | (define registry |
313 | (filter-map hash-get-handle | |
40f56176 | 314 | (make-list (length dependencies) |
35189728 | 315 | lisp-input-map) |
7b6b7cdc | 316 | (map dependency-name dependencies))) |
35189728 | 317 | |
5a08660e PN |
318 | ;; Ensure directory exists, which might not be the case for an .asd without components. |
319 | (mkdir-p (dirname asd-file)) | |
35189728 AP |
320 | (call-with-output-file asd-file |
321 | (lambda (port) | |
322 | (display | |
323 | (replace-escaped-macros | |
324 | (format #f "~y~%~y~%" | |
5a08660e PN |
325 | (generate-system-definition |
326 | system | |
327 | #:version version | |
328 | #:dependencies dependencies | |
329 | ;; Some .asd don't have components, and thus they don't generate any .fasl. | |
cdf34eed GLV |
330 | #:component? (match (%lisp-type) |
331 | ("sbcl" (pair? (find-files (dirname asd-file) | |
332 | "--system\\.fasl$"))) | |
333 | ("ecl" (pair? (find-files (dirname asd-file) | |
334 | "\\.fasb$"))) | |
335 | (_ (error "The LISP provided is not supported at this time.")))) | |
b4c9f0c5 | 336 | (generate-dependency-links registry system))) |
35189728 | 337 | port)))) |
a1b30f99 | 338 | |
b4c9f0c5 | 339 | (define (bundle-asd-file output-path original-asd-file) |
a1b30f99 AP |
340 | "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in |
341 | OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd. Returns two | |
342 | values: the asd file itself and the directory in which it resides." | |
343 | (let ((bundle-asd-path (string-append output-path | |
b4c9f0c5 | 344 | (%bundle-install-prefix)))) |
a1b30f99 AP |
345 | (values (string-append bundle-asd-path "/" (basename original-asd-file)) |
346 | bundle-asd-path))) | |
347 | ||
348 | (define (replace-escaped-macros string) | |
349 | "Replace simple lisp forms that the guile writer escapes, for example by | |
350 | replacing #{#p}# with #p. Should only be used to replace truly simple forms | |
351 | which are not nested." | |
352 | (regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string | |
353 | 'pre 2 'post)) | |
354 | ||
355 | (define (prepend-to-source-registry path) | |
356 | (setenv "CL_SOURCE_REGISTRY" | |
357 | (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") "")))) | |
358 | ||
4209c31b AP |
359 | (define* (build-program program outputs #:key |
360 | (dependency-prefixes (list (library-output outputs))) | |
a1b30f99 AP |
361 | (dependencies (list (basename program))) |
362 | entry-program | |
01e38cc4 | 363 | compress? |
a1b30f99 AP |
364 | #:allow-other-keys) |
365 | "Generate an executable program containing all DEPENDENCIES, and which will | |
366 | execute ENTRY-PROGRAM. The result is placed in PROGRAM. When executed, it | |
367 | will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments' | |
4209c31b AP |
368 | has been bound to the command-line arguments which were passed. Link in any |
369 | asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are | |
370 | retained." | |
b4c9f0c5 | 371 | (generate-executable program |
a1b30f99 | 372 | #:dependencies dependencies |
4209c31b | 373 | #:dependency-prefixes dependency-prefixes |
a1b30f99 | 374 | #:entry-program entry-program |
01e38cc4 | 375 | #:compress? compress? |
b9afcb9e | 376 | #:type 'asdf:program-op) |
a1b30f99 AP |
377 | (let* ((name (basename program)) |
378 | (bin-directory (dirname program))) | |
379 | (with-directory-excursion bin-directory | |
380 | (rename-file (string-append name "-exec") | |
381 | name))) | |
382 | #t) | |
383 | ||
4209c31b AP |
384 | (define* (build-image image outputs #:key |
385 | (dependency-prefixes (list (library-output outputs))) | |
a1b30f99 AP |
386 | (dependencies (list (basename image))) |
387 | #:allow-other-keys) | |
388 | "Generate an image, possibly standalone, which contains all DEPENDENCIES, | |
4209c31b AP |
389 | placing the result in IMAGE.image. Link in any asd files from |
390 | DEPENDENCY-PREFIXES to ensure references to those libraries are retained." | |
b4c9f0c5 | 391 | (generate-executable image |
a1b30f99 | 392 | #:dependencies dependencies |
4209c31b | 393 | #:dependency-prefixes dependency-prefixes |
a1b30f99 | 394 | #:entry-program '(nil) |
b9afcb9e | 395 | #:type 'asdf:image-op) |
a1b30f99 AP |
396 | (let* ((name (basename image)) |
397 | (bin-directory (dirname image))) | |
398 | (with-directory-excursion bin-directory | |
399 | (rename-file (string-append name "-exec--all-systems.image") | |
400 | (string-append name ".image")))) | |
401 | #t) | |
402 | ||
b4c9f0c5 | 403 | (define* (generate-executable out-file #:key |
a1b30f99 | 404 | dependencies |
4209c31b | 405 | dependency-prefixes |
a1b30f99 AP |
406 | entry-program |
407 | type | |
01e38cc4 | 408 | compress? |
a1b30f99 | 409 | #:allow-other-keys) |
b9afcb9e | 410 | "Generate an executable by using asdf operation TYPE, containing whithin the |
a1b30f99 | 411 | image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an |
4209c31b AP |
412 | executable. Link in any asd files from DEPENDENCY-PREFIXES to ensure |
413 | references to those libraries are retained." | |
a1b30f99 AP |
414 | (let* ((bin-directory (dirname out-file)) |
415 | (name (basename out-file))) | |
416 | (mkdir-p bin-directory) | |
417 | (with-directory-excursion bin-directory | |
418 | (generate-executable-wrapper-system name dependencies) | |
419 | (generate-executable-entry-point name entry-program)) | |
420 | ||
421 | (prepend-to-source-registry | |
422 | (string-append bin-directory "/")) | |
423 | ||
424 | (setenv "ASDF_OUTPUT_TRANSLATIONS" | |
425 | (replace-escaped-macros | |
426 | (format | |
427 | #f "~S" | |
428 | (wrap-output-translations | |
429 | `(((,bin-directory :**/ :*.*.*) | |
430 | (,bin-directory :**/ :*.*.*))))))) | |
431 | ||
01e38cc4 | 432 | (generate-executable-for-system type name #:compress? compress?) |
a1b30f99 | 433 | |
4209c31b AP |
434 | (let* ((after-store-prefix-index |
435 | (string-index out-file #\/ | |
436 | (1+ (string-length (%store-directory))))) | |
437 | (output (string-take out-file after-store-prefix-index)) | |
438 | (hidden-asd-links (string-append output "/.asd-files"))) | |
439 | ||
440 | (mkdir-p hidden-asd-links) | |
441 | (for-each | |
442 | (lambda (path) | |
443 | (for-each | |
444 | (lambda (asd-file) | |
445 | (symlink asd-file | |
446 | (string-append hidden-asd-links | |
447 | "/" (basename asd-file)))) | |
448 | (find-files (string-append path (%bundle-install-prefix)) | |
449 | "\\.asd$"))) | |
450 | dependency-prefixes)) | |
451 | ||
a1b30f99 AP |
452 | (delete-file (string-append bin-directory "/" name "-exec.asd")) |
453 | (delete-file (string-append bin-directory "/" name "-exec.lisp")))) |