0383afa02a
* guix/build-system/asdf.scm (asdf-build): Add a #:test-asd-file argument. [builder]: Pass it to the build system. (package-with-build-system)[transform]: Strip it from source systems' arguments. * guix/build/asdf-build-system.scm (check): Pass the fully qualified path to it on to the test-system procedure. * guix/build/lisp-utils.scm (test-system): Load the file, or otherwise one of the often used names for it, before running the tests. Adjust the docstring accordingly.
410 lines
15 KiB
Scheme
410 lines
15 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
|
;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca>
|
|
;;;
|
|
;;; This file is part of GNU Guix.
|
|
;;;
|
|
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
|
;;; under the terms of the GNU General Public License as published by
|
|
;;; the Free Software Foundation; either version 3 of the License, or (at
|
|
;;; your option) any later version.
|
|
;;;
|
|
;;; GNU Guix is distributed in the hope that it will be useful, but
|
|
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
;;; GNU General Public License for more details.
|
|
;;;
|
|
;;; You should have received a copy of the GNU General Public License
|
|
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
|
|
|
(define-module (guix build lisp-utils)
|
|
#:use-module (ice-9 format)
|
|
#:use-module (ice-9 hash-table)
|
|
#:use-module (ice-9 match)
|
|
#:use-module (ice-9 regex)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-26)
|
|
#:use-module (guix build utils)
|
|
#:export (%lisp
|
|
%lisp-type
|
|
%source-install-prefix
|
|
lisp-eval-program
|
|
compile-system
|
|
test-system
|
|
replace-escaped-macros
|
|
generate-executable-wrapper-system
|
|
generate-executable-entry-point
|
|
generate-executable-for-system
|
|
%bundle-install-prefix
|
|
bundle-asd-file
|
|
wrap-output-translations
|
|
prepend-to-source-registry
|
|
build-program
|
|
build-image
|
|
make-asd-file
|
|
valid-char-set
|
|
normalize-string
|
|
library-output))
|
|
|
|
;;; Commentary:
|
|
;;;
|
|
;;; Tools to evaluate lisp programs within a lisp session, generate wrapper
|
|
;;; systems for executables. Compile, test, and produce images for systems and
|
|
;;; programs, and link them with their dependencies.
|
|
;;;
|
|
;;; Code:
|
|
|
|
(define %lisp
|
|
;; File name of the Lisp compiler.
|
|
(make-parameter "lisp"))
|
|
|
|
(define %lisp-type
|
|
;; String representing the class of implementation being used.
|
|
(make-parameter "lisp"))
|
|
|
|
;; The common parent for Lisp source files, as will as the symbolic
|
|
;; link farm for system definition (.asd) files.
|
|
(define %source-install-prefix "/share/common-lisp")
|
|
|
|
(define (%bundle-install-prefix)
|
|
(string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems"))
|
|
|
|
(define (library-output outputs)
|
|
"If a `lib' output exists, build things there. Otherwise use `out'."
|
|
(or (assoc-ref outputs "lib") (assoc-ref outputs "out")))
|
|
|
|
;; See nix/libstore/store-api.cc#checkStoreName.
|
|
(define valid-char-set
|
|
(string->char-set
|
|
"0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+-._?="))
|
|
|
|
(define (normalize-string str)
|
|
"Replace invalid characters in STR with a hyphen."
|
|
(string-join (string-tokenize str valid-char-set) "-"))
|
|
|
|
(define (inputs->asd-file-map inputs)
|
|
"Produce a hash table of the form (system . asd-file), where system is the
|
|
name of an ASD system, and asd-file is the full path to its definition."
|
|
(alist->hash-table
|
|
(filter-map
|
|
(match-lambda
|
|
((_ . path)
|
|
(let ((prefix (string-append path (%bundle-install-prefix))))
|
|
(and (directory-exists? prefix)
|
|
(match (find-files prefix "\\.asd$")
|
|
((asd-file)
|
|
(cons
|
|
(string-drop-right (basename asd-file) 4) ; drop ".asd"
|
|
asd-file))
|
|
(_ #f))))))
|
|
inputs)))
|
|
|
|
(define (wrap-output-translations translations)
|
|
`(:output-translations
|
|
,@translations
|
|
:inherit-configuration))
|
|
|
|
(define (lisp-eval-program program)
|
|
"Evaluate PROGRAM with a given LISP implementation."
|
|
(unless (zero? (apply system*
|
|
(lisp-invocation program)))
|
|
(error "lisp-eval-program failed!" (%lisp) program)))
|
|
|
|
(define (spread-statements program argument-name)
|
|
"Return a list with the statements from PROGRAM spread between
|
|
ARGUMENT-NAME, a string representing the argument a lisp implementation uses
|
|
to accept statements to be evaluated before starting."
|
|
(append-map (lambda (statement)
|
|
(list argument-name (format #f "~S" statement)))
|
|
program))
|
|
|
|
(define (lisp-invocation program)
|
|
"Return a list of arguments for system* determining how to invoke LISP
|
|
with PROGRAM."
|
|
(match (%lisp-type)
|
|
("sbcl" `(,(%lisp) "--non-interactive"
|
|
,@(spread-statements program "--eval")))
|
|
("ecl" `(,(%lisp)
|
|
,@(spread-statements program "--eval")
|
|
"--eval" "(quit)"))
|
|
(_ (error "The LISP provided is not supported at this time."))))
|
|
|
|
(define (asdf-load-all systems)
|
|
(map (lambda (system)
|
|
`(asdf:load-system ,system))
|
|
systems))
|
|
|
|
(define (compile-system system asd-file)
|
|
"Use a lisp implementation to compile SYSTEM using asdf. Load ASD-FILE
|
|
first."
|
|
(lisp-eval-program
|
|
`((require :asdf)
|
|
(let ((*package* (find-package :asdf)))
|
|
(load ,asd-file))
|
|
(asdf:operate 'asdf:compile-bundle-op ,system))))
|
|
|
|
(define (system-dependencies system asd-file)
|
|
"Return the dependencies of SYSTEM, as reported by
|
|
asdf:system-depends-on. First load the system's ASD-FILE."
|
|
(define deps-file ".deps.sexp")
|
|
(define program
|
|
`((require :asdf)
|
|
(let ((*package* (find-package :asdf)))
|
|
(load ,asd-file))
|
|
(with-open-file
|
|
(stream ,deps-file :direction :output)
|
|
(format stream
|
|
"~s~%"
|
|
(asdf:system-depends-on
|
|
(asdf:find-system ,system))))))
|
|
|
|
(dynamic-wind
|
|
(lambda _
|
|
(lisp-eval-program program))
|
|
(lambda _
|
|
(call-with-input-file deps-file read))
|
|
(lambda _
|
|
(when (file-exists? deps-file)
|
|
(delete-file deps-file)))))
|
|
|
|
(define (compiled-system system)
|
|
(let ((system (basename system))) ; this is how asdf handles slashes
|
|
(match (%lisp-type)
|
|
("sbcl" (string-append system "--system"))
|
|
(_ system))))
|
|
|
|
(define* (generate-system-definition system
|
|
#:key version dependencies)
|
|
`(asdf:defsystem
|
|
,(normalize-string system)
|
|
:class asdf/bundle:prebuilt-system
|
|
:version ,version
|
|
:depends-on ,dependencies
|
|
:components ((:compiled-file ,(compiled-system system)))
|
|
,@(if (string=? "ecl" (%lisp-type))
|
|
`(:lib ,(string-append system ".a"))
|
|
'())))
|
|
|
|
(define (test-system system asd-file test-asd-file)
|
|
"Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first.
|
|
Also load TEST-ASD-FILE if necessary."
|
|
(lisp-eval-program
|
|
`((require :asdf)
|
|
(let ((*package* (find-package :asdf)))
|
|
(load ,asd-file)
|
|
,@(if test-asd-file
|
|
`((load ,test-asd-file))
|
|
;; Try some likely files.
|
|
(map (lambda (file)
|
|
`(when (uiop:file-exists-p ,file)
|
|
(load ,file)))
|
|
(list
|
|
(string-append system "-tests.asd")
|
|
(string-append system "-test.asd")
|
|
"tests.asd"
|
|
"test.asd"))))
|
|
(asdf:test-system ,system))))
|
|
|
|
(define (string->lisp-keyword . strings)
|
|
"Return a lisp keyword for the concatenation of STRINGS."
|
|
(string->symbol (apply string-append ":" strings)))
|
|
|
|
(define (generate-executable-for-system type system)
|
|
"Use LISP to generate an executable, whose TYPE can be 'asdf:image-op or
|
|
'asdf:program-op. The latter will always be standalone. Depends on having
|
|
created a \"SYSTEM-exec\" system which contains the entry program."
|
|
(lisp-eval-program
|
|
`((require :asdf)
|
|
(asdf:operate ',type ,(string-append system "-exec")))))
|
|
|
|
(define (generate-executable-wrapper-system system dependencies)
|
|
"Generates a system which can be used by asdf to produce an image or program
|
|
inside the current directory. The image or program will contain
|
|
DEPENDENCIES."
|
|
(with-output-to-file (string-append system "-exec.asd")
|
|
(lambda _
|
|
(format #t "~y~%"
|
|
`(defsystem ,(string->lisp-keyword system "-exec")
|
|
:entry-point ,(string-append system "-exec:main")
|
|
:depends-on (:uiop
|
|
,@(map string->lisp-keyword
|
|
dependencies))
|
|
:components ((:file ,(string-append system "-exec"))))))))
|
|
|
|
(define (generate-executable-entry-point system entry-program)
|
|
"Generates an entry point program from the list of lisp statements
|
|
ENTRY-PROGRAM for SYSTEM within the current directory."
|
|
(with-output-to-file (string-append system "-exec.lisp")
|
|
(lambda _
|
|
(let ((system (string->lisp-keyword system "-exec")))
|
|
(format #t "~{~y~%~%~}"
|
|
`((defpackage ,system
|
|
(:use :cl)
|
|
(:export :main))
|
|
|
|
(in-package ,system)
|
|
|
|
(defun main ()
|
|
(let ((arguments uiop:*command-line-arguments*))
|
|
(declare (ignorable arguments))
|
|
,@entry-program))))))))
|
|
|
|
(define (generate-dependency-links registry system)
|
|
"Creates a program which populates asdf's source registry from REGISTRY, an
|
|
alist of dependency names to corresponding asd files. This allows the system
|
|
to locate its dependent systems."
|
|
`(progn
|
|
(asdf/source-registry:ensure-source-registry)
|
|
,@(map (match-lambda
|
|
((name . asd-file)
|
|
`(setf
|
|
(gethash ,name
|
|
asdf/source-registry:*source-registry*)
|
|
,(string->symbol "#p")
|
|
,asd-file)))
|
|
registry)))
|
|
|
|
(define* (make-asd-file asd-file
|
|
#:key system version inputs
|
|
(system-asd-file #f))
|
|
"Create an ASD-FILE for SYSTEM@VERSION, appending a program to allow the
|
|
system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS."
|
|
(define dependencies
|
|
(let ((deps
|
|
(system-dependencies system system-asd-file)))
|
|
(if (eq? 'NIL deps)
|
|
'()
|
|
(map normalize-string deps))))
|
|
|
|
(define lisp-input-map
|
|
(inputs->asd-file-map inputs))
|
|
|
|
(define registry
|
|
(filter-map hash-get-handle
|
|
(make-list (length dependencies)
|
|
lisp-input-map)
|
|
dependencies))
|
|
|
|
(call-with-output-file asd-file
|
|
(lambda (port)
|
|
(display
|
|
(replace-escaped-macros
|
|
(format #f "~y~%~y~%"
|
|
(generate-system-definition system
|
|
#:version version
|
|
#:dependencies dependencies)
|
|
(generate-dependency-links registry system)))
|
|
port))))
|
|
|
|
(define (bundle-asd-file output-path original-asd-file)
|
|
"Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in
|
|
OUTPUT-PATH/share/common-lisp/LISP-bundle-systems/<system>.asd. Returns two
|
|
values: the asd file itself and the directory in which it resides."
|
|
(let ((bundle-asd-path (string-append output-path
|
|
(%bundle-install-prefix))))
|
|
(values (string-append bundle-asd-path "/" (basename original-asd-file))
|
|
bundle-asd-path)))
|
|
|
|
(define (replace-escaped-macros string)
|
|
"Replace simple lisp forms that the guile writer escapes, for example by
|
|
replacing #{#p}# with #p. Should only be used to replace truly simple forms
|
|
which are not nested."
|
|
(regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string
|
|
'pre 2 'post))
|
|
|
|
(define (prepend-to-source-registry path)
|
|
(setenv "CL_SOURCE_REGISTRY"
|
|
(string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") ""))))
|
|
|
|
(define* (build-program program outputs #:key
|
|
(dependency-prefixes (list (library-output outputs)))
|
|
(dependencies (list (basename program)))
|
|
entry-program
|
|
#:allow-other-keys)
|
|
"Generate an executable program containing all DEPENDENCIES, and which will
|
|
execute ENTRY-PROGRAM. The result is placed in PROGRAM. When executed, it
|
|
will run ENTRY-PROGRAM, a list of Common Lisp expressions in which `arguments'
|
|
has been bound to the command-line arguments which were passed. Link in any
|
|
asd files from DEPENDENCY-PREFIXES to ensure references to those libraries are
|
|
retained."
|
|
(generate-executable program
|
|
#:dependencies dependencies
|
|
#:dependency-prefixes dependency-prefixes
|
|
#:entry-program entry-program
|
|
#:type 'asdf:program-op)
|
|
(let* ((name (basename program))
|
|
(bin-directory (dirname program)))
|
|
(with-directory-excursion bin-directory
|
|
(rename-file (string-append name "-exec")
|
|
name)))
|
|
#t)
|
|
|
|
(define* (build-image image outputs #:key
|
|
(dependency-prefixes (list (library-output outputs)))
|
|
(dependencies (list (basename image)))
|
|
#:allow-other-keys)
|
|
"Generate an image, possibly standalone, which contains all DEPENDENCIES,
|
|
placing the result in IMAGE.image. Link in any asd files from
|
|
DEPENDENCY-PREFIXES to ensure references to those libraries are retained."
|
|
(generate-executable image
|
|
#:dependencies dependencies
|
|
#:dependency-prefixes dependency-prefixes
|
|
#:entry-program '(nil)
|
|
#:type 'asdf:image-op)
|
|
(let* ((name (basename image))
|
|
(bin-directory (dirname image)))
|
|
(with-directory-excursion bin-directory
|
|
(rename-file (string-append name "-exec--all-systems.image")
|
|
(string-append name ".image"))))
|
|
#t)
|
|
|
|
(define* (generate-executable out-file #:key
|
|
dependencies
|
|
dependency-prefixes
|
|
entry-program
|
|
type
|
|
#:allow-other-keys)
|
|
"Generate an executable by using asdf operation TYPE, containing whithin the
|
|
image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an
|
|
executable. Link in any asd files from DEPENDENCY-PREFIXES to ensure
|
|
references to those libraries are retained."
|
|
(let* ((bin-directory (dirname out-file))
|
|
(name (basename out-file)))
|
|
(mkdir-p bin-directory)
|
|
(with-directory-excursion bin-directory
|
|
(generate-executable-wrapper-system name dependencies)
|
|
(generate-executable-entry-point name entry-program))
|
|
|
|
(prepend-to-source-registry
|
|
(string-append bin-directory "/"))
|
|
|
|
(setenv "ASDF_OUTPUT_TRANSLATIONS"
|
|
(replace-escaped-macros
|
|
(format
|
|
#f "~S"
|
|
(wrap-output-translations
|
|
`(((,bin-directory :**/ :*.*.*)
|
|
(,bin-directory :**/ :*.*.*)))))))
|
|
|
|
(generate-executable-for-system type name)
|
|
|
|
(let* ((after-store-prefix-index
|
|
(string-index out-file #\/
|
|
(1+ (string-length (%store-directory)))))
|
|
(output (string-take out-file after-store-prefix-index))
|
|
(hidden-asd-links (string-append output "/.asd-files")))
|
|
|
|
(mkdir-p hidden-asd-links)
|
|
(for-each
|
|
(lambda (path)
|
|
(for-each
|
|
(lambda (asd-file)
|
|
(symlink asd-file
|
|
(string-append hidden-asd-links
|
|
"/" (basename asd-file))))
|
|
(find-files (string-append path (%bundle-install-prefix))
|
|
"\\.asd$")))
|
|
dependency-prefixes))
|
|
|
|
(delete-file (string-append bin-directory "/" name "-exec.asd"))
|
|
(delete-file (string-append bin-directory "/" name "-exec.lisp"))))
|