nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

build-system/asdf: Pass the system name as an argument to the builder. 

* guix/build-system/asdf.scm (asdf-build): Use the user-defined system name,
or calculate it from the package's full name.
[builder]: Pass the value along to the build procedure.
(package-with-build-system): Remove #:asd-system-name from source packages'
arguments.
* guix/build/asdf-build-system.scm: Adjust accordingly.
* guix/build/lisp-utils.scm (remove-lisp-from-name): Delete variable.
This commit is contained in:
Andy Patterson 2017-04-08 23:48:38 -04:00 committed by Ricardo Wurmus
parent b4c9f0c50d
commit 457702b1d9
No known key found for this signature in database
GPG Key ID: 197A5888235FACAC
3 changed files with 32 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
guix/build-system/asdf.scm
View File

@ -22,6 +22,9 @@
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix derivations) #:use-module (guix derivations)
#:use-module (guix search-paths) #:use-module (guix search-paths)
#:use-module ((guix build utils)
#:select ((package-name->name+version
. hyphen-separated-name->name+version)))
#:use-module (guix build-system) #:use-module (guix build-system)
#:use-module (guix build-system gnu) #:use-module (guix build-system gnu)
#:use-module (ice-9 match) #:use-module (ice-9 match)
@ -196,7 +199,7 @@ set up using CL source package conventions."
(define base-arguments (define base-arguments
(if target-is-source? (if target-is-source?
(strip-keyword-arguments (strip-keyword-arguments
'(#:tests? #:asd-file #:lisp) '(#:tests? #:asd-file #:lisp #:asd-system-name)
(package-arguments pkg)) (package-arguments pkg))
(package-arguments pkg))) (package-arguments pkg)))
@ -262,6 +265,7 @@ set up using CL source package conventions."
#:key source outputs #:key source outputs
(tests? #t) (tests? #t)
(asd-file #f) (asd-file #f)
(asd-system-name #f)
(phases '(@ (guix build asdf-build-system) (phases '(@ (guix build asdf-build-system)
%standard-phases)) %standard-phases))
(search-paths '()) (search-paths '())
@ -270,6 +274,13 @@ set up using CL source package conventions."
(imported-modules %asdf-build-system-modules) (imported-modules %asdf-build-system-modules)
(modules %asdf-build-modules)) (modules %asdf-build-modules))
(define system-name
(or asd-system-name
(string-drop
;; NAME is the value returned from `package-full-name'.
(hyphen-separated-name->name+version name)
(1+ (string-length lisp-type))))) ; drop the "<lisp>-" prefix.
(define builder (define builder
`(begin `(begin
(use-modules ,@modules) (use-modules ,@modules)
@ -284,6 +295,7 @@ set up using CL source package conventions."
((source) source) ((source) source)
(source source)) (source source))
#:asd-file ,asd-file #:asd-file ,asd-file
#:asd-system-name ,system-name
#:system ,system #:system ,system
#:tests? ,tests? #:tests? ,tests?
#:phases ,phases #:phases ,phases

45
guix/build/asdf-build-system.scm
View File

@ -49,13 +49,6 @@
(define %system-install-prefix (define %system-install-prefix
(string-append %source-install-prefix "/systems")) (string-append %source-install-prefix "/systems"))
(define (output-path->package-name path)
(package-name->name+version (strip-store-file-name path)))
(define (outputs->name outputs)
(output-path->package-name
(assoc-ref outputs "out")))
(define (lisp-source-directory output name) (define (lisp-source-directory output name)
(string-append output (%lisp-source-install-prefix) "/" name)) (string-append output (%lisp-source-install-prefix) "/" name))
@ -101,31 +94,32 @@ valid."
(define* (install #:key outputs #:allow-other-keys) (define* (install #:key outputs #:allow-other-keys)
"Copy and symlink all the source files." "Copy and symlink all the source files."
(copy-files-to-output (assoc-ref outputs "out") (outputs->name outputs))) (define output (assoc-ref outputs "out"))
(copy-files-to-output output
(package-name->name+version
(strip-store-file-name output))))
(define* (copy-source #:key outputs #:allow-other-keys) (define* (copy-source #:key outputs asd-system-name #:allow-other-keys)
"Copy the source to the library output." "Copy the source to the library output."
(let* ((out (library-output outputs)) (let* ((out (library-output outputs))
(name (remove-lisp-from-name (output-path->package-name out)))
(install-path (string-append out %source-install-prefix))) (install-path (string-append out %source-install-prefix)))
(copy-files-to-output out name) (copy-files-to-output out asd-system-name)
;; Hide the files from asdf ;; Hide the files from asdf
(with-directory-excursion install-path (with-directory-excursion install-path
(rename-file "source" (string-append (%lisp-type) "-source")) (rename-file "source" (string-append (%lisp-type) "-source"))
(delete-file-recursively "systems"))) (delete-file-recursively "systems")))
#t) #t)
(define* (build #:key outputs inputs asd-file (define* (build #:key outputs inputs asd-file asd-system-name
#:allow-other-keys) #:allow-other-keys)
"Compile the system." "Compile the system."
(let* ((out (library-output outputs)) (let* ((out (library-output outputs))
(name (remove-lisp-from-name (output-path->package-name out))) (source-path (lisp-source-directory out asd-system-name))
(source-path (lisp-source-directory out name))
(translations (wrap-output-translations (translations (wrap-output-translations
`(,(output-translation source-path `(,(output-translation source-path
out)))) out))))
(asd-file (and=> asd-file (asd-file (and=> asd-file
(cut source-asd-file out name <>)))) (cut source-asd-file out asd-system-name <>))))
(setenv "ASDF_OUTPUT_TRANSLATIONS" (setenv "ASDF_OUTPUT_TRANSLATIONS"
(replace-escaped-macros (format #f "~S" translations))) (replace-escaped-macros (format #f "~S" translations)))
@ -137,7 +131,7 @@ valid."
(setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache
(compile-system name asd-file) (compile-system asd-system-name asd-file)
;; As above, ecl will sometimes create this even though it doesn't use it ;; As above, ecl will sometimes create this even though it doesn't use it
@ -146,32 +140,31 @@ valid."
(delete-file-recursively cache-directory)))) (delete-file-recursively cache-directory))))
#t) #t)
(define* (check #:key tests? outputs inputs asd-file (define* (check #:key tests? outputs inputs asd-file asd-system-name
#:allow-other-keys) #:allow-other-keys)
"Test the system." "Test the system."
(let* ((name (remove-lisp-from-name (outputs->name outputs))) (let* ((out (library-output outputs))
(out (library-output outputs))
(asd-file (and=> asd-file (asd-file (and=> asd-file
(cut source-asd-file out name <>)))) (cut source-asd-file out asd-system-name <>))))
(if tests? (if tests?
(test-system name asd-file) (test-system asd-system-name asd-file)
(format #t "test suite not run~%"))) (format #t "test suite not run~%")))
#t) #t)
(define* (create-asd-file #:key outputs (define* (create-asd-file #:key outputs
inputs inputs
asd-file asd-file
asd-system-name
#:allow-other-keys) #:allow-other-keys)
"Create a system definition file for the built system." "Create a system definition file for the built system."
(let*-values (((out) (library-output outputs)) (let*-values (((out) (library-output outputs))
((full-name version) (package-name->name+version ((_ version) (package-name->name+version
(strip-store-file-name out))) (strip-store-file-name out)))
((name) (remove-lisp-from-name full-name))
((new-asd-file) (string-append (library-directory out) ((new-asd-file) (string-append (library-directory out)
"/" name ".asd"))) "/" asd-system-name ".asd")))
(make-asd-file new-asd-file (make-asd-file new-asd-file
#:system name #:system asd-system-name
#:version version #:version version
#:inputs inputs #:inputs inputs
#:system-asd-file asd-file)) #:system-asd-file asd-file))

4
guix/build/lisp-utils.scm
View File

@ -36,7 +36,6 @@
generate-executable-for-system generate-executable-for-system
%bundle-install-prefix %bundle-install-prefix
bundle-asd-file bundle-asd-file
remove-lisp-from-name
wrap-output-translations wrap-output-translations
prepend-to-source-registry prepend-to-source-registry
build-program build-program
@ -66,9 +65,6 @@
(define (%bundle-install-prefix) (define (%bundle-install-prefix)
(string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems")) (string-append %source-install-prefix "/" (%lisp-type) "-bundle-systems"))
(define (remove-lisp-from-name name lisp)
(string-drop name (1+ (string-length lisp))))
(define (inputs->asd-file-map inputs) (define (inputs->asd-file-map inputs)
"Produce a hash table of the form (system . asd-file), where system is the "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." name of an ASD system, and asd-file is the full path to its definition."