aboutsummaryrefslogtreecommitdiff
path: root/guix/build-system/asdf.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guix/build-system/asdf.scm')
-rw-r--r--guix/build-system/asdf.scm360
1 files changed, 360 insertions, 0 deletions
diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm
new file mode 100644
index 0000000000..f28c098ea2
--- /dev/null
+++ b/guix/build-system/asdf.scm
@@ -0,0 +1,360 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 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-system asdf)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (guix derivations)
+ #:use-module (guix search-paths)
+ #:use-module (guix build-system)
+ #:use-module (guix build-system gnu)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:export (%asdf-build-system-modules
+ %asdf-build-modules
+ asdf-build
+ asdf-build-system/sbcl
+ asdf-build-system/ecl
+ asdf-build-system/source
+ sbcl-package->cl-source-package
+ sbcl-package->ecl-package))
+
+;; Commentary:
+;;
+;; Standard build procedure for asdf packages. This is implemented as an
+;; extension of 'gnu-build-system'.
+;;
+;; Code:
+
+(define %asdf-build-system-modules
+ ;; Imported build-side modules
+ `((guix build asdf-build-system)
+ (guix build lisp-utils)
+ ,@%gnu-build-system-modules))
+
+(define %asdf-build-modules
+ ;; Used (visible) build-side modules
+ '((guix build asdf-build-system)
+ (guix build utils)
+ (guix build lisp-utils)))
+
+(define (default-lisp implementation)
+ "Return the default package for the lisp IMPLEMENTATION."
+ ;; Lazily resolve the binding to avoid a circular dependancy.
+ (let ((lisp-module (resolve-interface '(gnu packages lisp))))
+ (module-ref lisp-module implementation)))
+
+(define* (lower/source name
+ #:key source inputs outputs native-inputs system target
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME"
+ (define private-keywords
+ '(#:target #:inputs #:native-inputs))
+
+ (and (not target)
+ (bag
+ (name name)
+ (system system)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+ ,@(standard-packages)))
+ (build-inputs native-inputs)
+ (outputs outputs)
+ (build asdf-build/source)
+ (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (asdf-build/source store name inputs
+ #:key source outputs
+ (phases '(@ (guix build asdf-build-system)
+ %standard-phases/source))
+ (search-paths '())
+ (system (%current-system))
+ (guile #f)
+ (imported-modules %asdf-build-system-modules)
+ (modules %asdf-build-modules))
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (asdf-build/source #:name ,name
+ #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source) source)
+ (source source))
+ #:system ,system
+ #:phases ,phases
+ #:outputs %outputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:inputs %build-inputs)))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:inputs inputs
+ #:system system
+ #:modules imported-modules
+ #:outputs outputs
+ #:guile-for-build guile-for-build))
+
+(define* (package-with-build-system from-build-system to-build-system
+ from-prefix to-prefix
+ #:key variant-property
+ phases-transformer)
+ "Return a precedure which takes a package PKG which uses FROM-BUILD-SYSTEM,
+and returns one using TO-BUILD-SYSTEM. If PKG was prefixed by FROM-PREFIX,
+the resulting package will be prefixed by TO-PREFIX. Inputs of PKG are
+recursively transformed using the same rule. The result's #:phases argument
+will be modified by PHASES-TRANSFORMER, an S-expression which evaluates on the
+build side to a procedure of one argument.
+
+VARIANT-PROPERTY can be added to a package's properties to indicate that the
+corresponding package promise should be used as the result of this
+transformation. This allows the result to differ from what the transformation
+would otherwise produce.
+
+If TO-BUILD-SYSTEM is asdf-build-system/source, the resulting package will be
+set up using CL source package conventions."
+ (define target-is-source? (eq? asdf-build-system/source to-build-system))
+
+ (define (transform-package-name name)
+ (if (string-prefix? from-prefix name)
+ (let ((new-name (string-drop name (string-length from-prefix))))
+ (if (string-prefix? to-prefix new-name)
+ new-name
+ (string-append to-prefix new-name)))
+ name))
+
+ (define (has-from-build-system? pkg)
+ (eq? from-build-system (package-build-system pkg)))
+
+ (define transform
+ (memoize
+ (lambda (pkg)
+ (define rewrite
+ (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)))))
+
+ ;; Special considerations for source packages: CL inputs become
+ ;; propagated, and un-handled arguments are removed. Native inputs are
+ ;; removed as are extraneous outputs.
+ (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
+ (if target-is-source?
+ (map rewrite
+ (filter (match-lambda
+ ((_ input . _)
+ (not (has-from-build-system? input))))
+ (package-inputs pkg)))
+ (map rewrite (package-inputs pkg))))
+
+ (define base-arguments
+ (if target-is-source?
+ (strip-keyword-arguments
+ '(#:tests? #:special-dependencies #:asd-file
+ #:test-only-systems #:lisp)
+ (package-arguments pkg))
+ (package-arguments pkg)))
+
+ (cond
+ ((and variant-property
+ (assoc-ref (package-properties pkg) variant-property))
+ => force)
+
+ ((has-from-build-system? pkg)
+ (package
+ (inherit pkg)
+ (location (package-location pkg))
+ (name (transform-package-name (package-name pkg)))
+ (build-system to-build-system)
+ (arguments
+ (substitute-keyword-arguments base-arguments
+ ((#:phases phases) (list phases-transformer phases))))
+ (inputs new-inputs)
+ (propagated-inputs new-propagated-inputs)
+ (native-inputs (if target-is-source?
+ '()
+ (map rewrite (package-native-inputs pkg))))
+ (outputs (if target-is-source?
+ '("out")
+ (package-outputs pkg)))))
+ (else pkg)))))
+
+ transform)
+
+(define (strip-variant-as-necessary variant pkg)
+ (define properties (package-properties pkg))
+ (if (assoc variant properties)
+ (package
+ (inherit pkg)
+ (properties (alist-delete variant properties)))
+ pkg))
+
+(define (lower lisp-implementation)
+ (lambda* (name
+ #:key source inputs outputs native-inputs system target
+ (lisp (default-lisp (string->symbol lisp-implementation)))
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME"
+ (define private-keywords
+ '(#:target #:inputs #:native-inputs #:lisp))
+
+ (and (not target)
+ (bag
+ (name name)
+ (system system)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+ ,@(standard-packages)))
+ (build-inputs `((,lisp-implementation ,lisp)
+ ,@native-inputs))
+ (outputs outputs)
+ (build (asdf-build lisp-implementation))
+ (arguments (strip-keyword-arguments private-keywords arguments))))))
+
+(define (asdf-build lisp-implementation)
+ (lambda* (store name inputs
+ #:key source outputs
+ (tests? #t)
+ (special-dependencies ''())
+ (asd-file #f)
+ (test-only-systems ''())
+ (lisp lisp-implementation)
+ (phases '(@ (guix build asdf-build-system)
+ %standard-phases))
+ (search-paths '())
+ (system (%current-system))
+ (guile #f)
+ (imported-modules %asdf-build-system-modules)
+ (modules %asdf-build-modules))
+
+ (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)))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:inputs inputs
+ #:system system
+ #:modules imported-modules
+ #:outputs outputs
+ #:guile-for-build guile-for-build)))
+
+(define asdf-build-system/sbcl
+ (build-system
+ (name 'asdf/sbcl)
+ (description "The build system for ASDF binary packages using SBCL")
+ (lower (lower "sbcl"))))
+
+(define asdf-build-system/ecl
+ (build-system
+ (name 'asdf/ecl)
+ (description "The build system for ASDF binary packages using ECL")
+ (lower (lower "ecl"))))
+
+(define asdf-build-system/source
+ (build-system
+ (name 'asdf/source)
+ (description "The build system for ASDF source packages")
+ (lower lower/source)))
+
+(define sbcl-package->cl-source-package
+ (let* ((property 'cl-source-variant)
+ (transformer
+ (package-with-build-system asdf-build-system/sbcl
+ asdf-build-system/source
+ "sbcl-"
+ "cl-"
+ #:variant-property property
+ #:phases-transformer
+ '(const %standard-phases/source))))
+ (lambda (pkg)
+ (transformer
+ (strip-variant-as-necessary property pkg)))))
+
+(define sbcl-package->ecl-package
+ (let* ((property 'ecl-variant)
+ (transformer
+ (package-with-build-system asdf-build-system/sbcl
+ asdf-build-system/ecl
+ "sbcl-"
+ "ecl-"
+ #:variant-property property
+ #:phases-transformer
+ 'identity)))
+ (lambda (pkg)
+ (transformer
+ (strip-variant-as-necessary property pkg)))))
+
+;;; asdf.scm ends here