diff options
Diffstat (limited to 'guix/build-system/asdf.scm')
| -rw-r--r-- | guix/build-system/asdf.scm | 109 |
1 files changed, 60 insertions, 49 deletions
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index f28c098ea2..ec8b64497f 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca> +;;; Copyright © 2016, 2017 Andy Patterson <ajpatter@uwaterloo.ca> ;;; ;;; This file is part of GNU Guix. ;;; @@ -22,6 +22,9 @@ #:use-module (guix packages) #:use-module (guix derivations) #: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 gnu) #:use-module (ice-9 match) @@ -163,39 +166,40 @@ set up using CL source package conventions." (match-lambda ((name content . rest) (let* ((is-package? (package? content)) - (new-content (if is-package? (transform content) content)) - (new-name (if (and is-package? - (string-prefix? from-prefix name)) - (package-name new-content) - name))) - `(,new-name ,new-content ,@rest))))) + (new-content (if is-package? (transform content) content))) + `(,name ,new-content ,@rest))))) ;; Special considerations for source packages: CL inputs become - ;; propagated, and un-handled arguments are removed. Native inputs are - ;; removed as are extraneous outputs. + ;; propagated, and un-handled arguments are removed. + (define new-propagated-inputs (if target-is-source? (map rewrite - (filter (match-lambda - ((_ input . _) - (has-from-build-system? input))) - (package-inputs pkg))) - '())) - - (define new-inputs + (append + (filter (match-lambda + ((_ input . _) + (has-from-build-system? input))) + (append (package-inputs pkg) + ;; The native inputs might be needed just + ;; to load the system. + (package-native-inputs pkg))) + (package-propagated-inputs pkg))) + + (map rewrite (package-propagated-inputs pkg)))) + + (define (new-inputs inputs-getter) (if target-is-source? (map rewrite (filter (match-lambda ((_ input . _) (not (has-from-build-system? input)))) - (package-inputs pkg))) - (map rewrite (package-inputs pkg)))) + (inputs-getter pkg))) + (map rewrite (inputs-getter pkg)))) (define base-arguments (if target-is-source? (strip-keyword-arguments - '(#:tests? #:special-dependencies #:asd-file - #:test-only-systems #:lisp) + '(#:tests? #:asd-file #:lisp #:asd-system-name #:test-asd-file) (package-arguments pkg)) (package-arguments pkg))) @@ -213,11 +217,9 @@ set up using CL source package conventions." (arguments (substitute-keyword-arguments base-arguments ((#:phases phases) (list phases-transformer phases)))) - (inputs new-inputs) + (inputs (new-inputs package-inputs)) (propagated-inputs new-propagated-inputs) - (native-inputs (if target-is-source? - '() - (map rewrite (package-native-inputs pkg)))) + (native-inputs (new-inputs package-native-inputs)) (outputs (if target-is-source? '("out") (package-outputs pkg))))) @@ -233,10 +235,10 @@ set up using CL source package conventions." (properties (alist-delete variant properties))) pkg)) -(define (lower lisp-implementation) +(define (lower lisp-type) (lambda* (name #:key source inputs outputs native-inputs system target - (lisp (default-lisp (string->symbol lisp-implementation))) + (lisp (default-lisp (string->symbol lisp-type))) #:allow-other-keys #:rest arguments) "Return a bag for NAME" @@ -252,20 +254,19 @@ set up using CL source package conventions." '()) ,@inputs ,@(standard-packages))) - (build-inputs `((,lisp-implementation ,lisp) + (build-inputs `((,lisp-type ,lisp) ,@native-inputs)) (outputs outputs) - (build (asdf-build lisp-implementation)) + (build (asdf-build lisp-type)) (arguments (strip-keyword-arguments private-keywords arguments)))))) -(define (asdf-build lisp-implementation) +(define (asdf-build lisp-type) (lambda* (store name inputs #:key source outputs (tests? #t) - (special-dependencies ''()) (asd-file #f) - (test-only-systems ''()) - (lisp lisp-implementation) + (asd-system-name #f) + (test-asd-file #f) (phases '(@ (guix build asdf-build-system) %standard-phases)) (search-paths '()) @@ -274,26 +275,36 @@ set up using CL source package conventions." (imported-modules %asdf-build-system-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 `(begin (use-modules ,@modules) - (asdf-build #:name ,name - #:source ,(match (assoc-ref inputs "source") - (((? derivation? source)) - (derivation->output-path source)) - ((source) source) - (source source)) - #:lisp ,lisp - #:special-dependencies ,special-dependencies - #:asd-file ,asd-file - #:test-only-systems ,test-only-systems - #:system ,system - #:tests? ,tests? - #:phases ,phases - #:outputs %outputs - #:search-paths ',(map search-path-specification->sexp - search-paths) - #:inputs %build-inputs))) + (parameterize ((%lisp (string-append + (assoc-ref %build-inputs ,lisp-type) + "/bin/" ,lisp-type)) + (%lisp-type ,lisp-type)) + (asdf-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) source) + (source source)) + #:asd-file ,(or asd-file (string-append system-name ".asd")) + #:asd-system-name ,system-name + #:test-asd-file ,test-asd-file + #:system ,system + #:tests? ,tests? + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs)))) (define guile-for-build (match guile |