From 1618006d0bc9bfdc63f4d199fd980f29ecc78ec4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 5 Apr 2017 21:32:13 +0200 Subject: build-system/python: 'package-with-explicit-python' uses 'package-mapping'. * guix/build-system/python.scm (package-with-explicit-python) [package-variant, cut?]: New procedures. [transform]: Remove 'mlambdaq' form and input tuple handling. Use 'package-mapping'. --- guix/build-system/python.scm | 85 +++++++++++++++++++------------------------- 1 file changed, 37 insertions(+), 48 deletions(-) (limited to 'guix/build-system') diff --git a/guix/build-system/python.scm b/guix/build-system/python.scm index 17173f121e..ffed837313 100644 --- a/guix/build-system/python.scm +++ b/guix/build-system/python.scm @@ -83,54 +83,43 @@ pre-defined variants of this transformation recorded in the 'properties' field of packages. The property value must be the promise of a package. This is a convenient way for package writers to force the transformation to use pre-defined variants." - (define transform - ;; Memoize the transformations. Failing to do that, we would build a huge - ;; object graph with lots of duplicates, which in turns prevents us from - ;; benefiting from memoization in 'package-derivation'. - (mlambdaq (p) - (let* ((rewrite-if-package - (lambda (content) - ;; CONTENT may be a file name, in which case it is returned, - ;; or a package, which is rewritten with the new PYTHON and - ;; NEW-PREFIX. - (if (package? content) - (transform content) - content))) - (rewrite - (match-lambda - ((name content . rest) - (append (list name (rewrite-if-package content)) rest))))) - - (cond - ;; If VARIANT-PROPERTY is present, use that. - ((and variant-property - (assoc-ref (package-properties p) variant-property)) - => force) - - ;; Otherwise build the new package object graph. - ((eq? (package-build-system p) python-build-system) - (package - (inherit p) - (location (package-location p)) - (name (let ((name (package-name p))) - (string-append new-prefix - (if (string-prefix? old-prefix name) - (substring name - (string-length old-prefix)) - name)))) - (arguments - (let ((python (if (promise? python) - (force python) - python))) - (ensure-keyword-arguments (package-arguments p) - `(#:python ,python)))) - (inputs (map rewrite (package-inputs p))) - (propagated-inputs (map rewrite (package-propagated-inputs p))) - (native-inputs (map rewrite (package-native-inputs p))))) - (else - p))))) - - transform) + (define package-variant + (if variant-property + (lambda (package) + (assq-ref (package-properties package) + variant-property)) + (const #f))) + + (define (transform p) + (cond + ;; If VARIANT-PROPERTY is present, use that. + ((package-variant p) + => force) + + ;; Otherwise build the new package object graph. + ((eq? (package-build-system p) python-build-system) + (package + (inherit p) + (location (package-location p)) + (name (let ((name (package-name p))) + (string-append new-prefix + (if (string-prefix? old-prefix name) + (substring name + (string-length old-prefix)) + name)))) + (arguments + (let ((python (if (promise? python) + (force python) + python))) + (ensure-keyword-arguments (package-arguments p) + `(#:python ,python)))))) + (else p))) + + (define (cut? p) + (or (not (eq? (package-build-system p) python-build-system)) + (package-variant p))) + + (package-mapping transform cut?)) (define package-with-python2 ;; Note: delay call to 'default-python2' until after the 'arguments' field -- cgit v1.2.3 From 8df64f7384263764a3c1bcfdb783c8188570cce7 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Fri, 9 Sep 2016 16:51:01 +0200 Subject: ant-build-system: Allow specifying source directory. * guix/build-system/ant.scm (ant-build), guix/build/ant-build-system.scm (default-build.xml): Add parameter source-dir. * guix/build/ant-build-system.scm (configure): Pass source-dir on to default-build.xml. * doc/guix.texi (Build Systems): Document it. Co-authored-by: Ricardo Wurmus --- doc/guix.texi | 3 ++- guix/build-system/ant.scm | 2 ++ guix/build/ant-build-system.scm | 10 ++++++---- 3 files changed, 10 insertions(+), 5 deletions(-) (limited to 'guix/build-system') diff --git a/doc/guix.texi b/doc/guix.texi index 22dc8b3f90..81aa957c6d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -3327,7 +3327,8 @@ parameters, respectively. When the original package does not provide a suitable Ant build file, the parameter @code{#:jar-name} can be used to generate a minimal Ant build file @file{build.xml} with tasks to build the specified jar -archive. +archive. In this case the parameter @code{#:source-dir} can be used to +specify the source sub-directory, defaulting to ``src''. The parameter @code{#:build-target} can be used to specify the Ant task that should be run during the @code{build} phase. By default the diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index 550f92bc7f..a309a0c86b 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -98,6 +98,7 @@ (make-flags ''()) (build-target "jar") (jar-name #f) + (source-dir "src") (phases '(@ (guix build ant-build-system) %standard-phases)) (outputs '("out")) @@ -126,6 +127,7 @@ #:test-target ,test-target #:build-target ,build-target #:jar-name ,jar-name + #:source-dir ,source-dir #:phases ,phases #:outputs %outputs #:search-paths ',(map search-path-specification->sexp diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index 00a4a46d81..8ec7a94869 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -35,7 +35,8 @@ ;; ;; Code: -(define (default-build.xml jar-name prefix) +(define* (default-build.xml jar-name prefix #:optional + (source-dir ".")) "Create a simple build.xml with standard targets for Ant." (call-with-output-file "build.xml" (lambda (port) @@ -58,7 +59,7 @@ (target (@ (name "compile")) (mkdir (@ (dir "${classes.dir}"))) (javac (@ (includeantruntime "false") - (srcdir "src") + (srcdir ,source-dir) (destdir "${classes.dir}") (classpath (@ (refid "classpath")))))) @@ -98,11 +99,12 @@ to the default GNU unpack strategy." ((assq-ref gnu:%standard-phases 'unpack) #:source source))) (define* (configure #:key inputs outputs (jar-name #f) - #:allow-other-keys) + (source-dir "src") #:allow-other-keys) (when jar-name (default-build.xml jar-name (string-append (assoc-ref outputs "out") - "/share/java"))) + "/share/java") + source-dir)) (setenv "JAVA_HOME" (assoc-ref inputs "jdk")) (setenv "CLASSPATH" (generate-classpath inputs))) -- cgit v1.2.3 From 52a791f50ffe460e2985dc356f08789d2d6f9f12 Mon Sep 17 00:00:00 2001 From: Ricardo Wurmus Date: Mon, 17 Oct 2016 19:32:14 +0200 Subject: ant-build-system: Add default "check" target. * guix/build-system/ant.scm (ant-build): Change default test target to "check"; add "test-dir" argument. * guix/build/ant-build-system.scm (default-build.xml): Add "test-dir" argument; add ant targets "compile-tests" and "check". (configure): Add "test-dir" argument; pass it to "default-build.xml". --- guix/build-system/ant.scm | 4 +++- guix/build/ant-build-system.scm | 40 +++++++++++++++++++++++++++++++++++++--- 2 files changed, 40 insertions(+), 4 deletions(-) (limited to 'guix/build-system') diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index a309a0c86b..bf2f3b4115 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -93,12 +93,13 @@ (define* (ant-build store name inputs #:key (tests? #t) - (test-target "tests") + (test-target "check") (configure-flags ''()) (make-flags ''()) (build-target "jar") (jar-name #f) (source-dir "src") + (test-dir "src/test") (phases '(@ (guix build ant-build-system) %standard-phases)) (outputs '("out")) @@ -128,6 +129,7 @@ #:build-target ,build-target #:jar-name ,jar-name #:source-dir ,source-dir + #:test-dir ,test-dir #:phases ,phases #:outputs %outputs #:search-paths ',(map search-path-specification->sexp diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index 8ec7a94869..4042630a10 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -36,7 +36,7 @@ ;; Code: (define* (default-build.xml jar-name prefix #:optional - (source-dir ".")) + (source-dir ".") (test-dir "./test")) "Create a simple build.xml with standard targets for Ant." (call-with-output-file "build.xml" (lambda (port) @@ -48,6 +48,10 @@ (value "${basedir}/build/jar"))) (property (@ (name "dist.dir") (value ,prefix))) + (property (@ (name "test.home") + (value ,test-dir))) + (property (@ (name "test.classes.dir") + (value "${basedir}/build/test-classes"))) ;; respect the CLASSPATH environment variable (property (@ (name "build.sysclasspath") @@ -63,6 +67,35 @@ (destdir "${classes.dir}") (classpath (@ (refid "classpath")))))) + (target (@ (name "compile-tests")) + (mkdir (@ (dir "${test.classes.dir}"))) + (javac (@ (includeantruntime "false") + (srcdir ,test-dir) + (destdir "${test.classes.dir}")) + (classpath + (pathelement (@ (path "${env.CLASSPATH}"))) + (pathelement (@ (location "${classes.dir}"))) + (pathelement (@ (location "${test.classes.dir}")))))) + + (target (@ (name "check") + (depends "compile-tests")) + (mkdir (@ (dir "${test.home}/test-reports"))) + (junit (@ (printsummary "true") + (showoutput "true") + (fork "yes") + (haltonfailure "yes")) + (classpath + (pathelement (@ (path "${env.CLASSPATH}"))) + (pathelement (@ (location "${test.home}/resources"))) + (pathelement (@ (location "${classes.dir}"))) + (pathelement (@ (location "${test.classes.dir}")))) + (formatter (@ (type "plain") + (usefile "true"))) + (batchtest (@ (fork "yes") + (todir "${test.home}/test-reports")) + (fileset (@ (dir "${test.home}/java")) + (include (@ (name "**/*Test.java" ))))))) + (target (@ (name "jar") (depends "compile")) (mkdir (@ (dir "${jar.dir}"))) @@ -99,12 +132,13 @@ to the default GNU unpack strategy." ((assq-ref gnu:%standard-phases 'unpack) #:source source))) (define* (configure #:key inputs outputs (jar-name #f) - (source-dir "src") #:allow-other-keys) + (source-dir "src") + (test-dir "src/test") #:allow-other-keys) (when jar-name (default-build.xml jar-name (string-append (assoc-ref outputs "out") "/share/java") - source-dir)) + source-dir test-dir)) (setenv "JAVA_HOME" (assoc-ref inputs "jdk")) (setenv "CLASSPATH" (generate-classpath inputs))) -- cgit v1.2.3 From 59135f0d7e52657bff8bc9f8b0a9133ee671f777 Mon Sep 17 00:00:00 2001 From: Hartmut Goebel Date: Fri, 9 Sep 2016 16:51:03 +0200 Subject: guix: Add java-utils. * guix/build/java-utils.scm: New file. * guix/build-system/ant.scm: Use it. * Makefile.am (MODULES): Add it. Co-authored-by: Ricardo Wurmus --- Makefile.am | 1 + guix/build-system/ant.scm | 2 ++ guix/build/java-utils.scm | 55 +++++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 58 insertions(+) create mode 100644 guix/build/java-utils.scm (limited to 'guix/build-system') diff --git a/Makefile.am b/Makefile.am index 3d91617b0d..d85b671bb4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -124,6 +124,7 @@ MODULES = \ guix/build/syscalls.scm \ guix/build/gremlin.scm \ guix/build/emacs-utils.scm \ + guix/build/java-utils.scm \ guix/build/lisp-utils.scm \ guix/build/graft.scm \ guix/build/bournish.scm \ diff --git a/guix/build-system/ant.scm b/guix/build-system/ant.scm index bf2f3b4115..228b4e60d2 100644 --- a/guix/build-system/ant.scm +++ b/guix/build-system/ant.scm @@ -39,6 +39,7 @@ (define %ant-build-system-modules ;; Build-side modules imported by default. `((guix build ant-build-system) + (guix build java-utils) (guix build syscalls) ,@%gnu-build-system-modules)) @@ -108,6 +109,7 @@ (guile #f) (imported-modules %ant-build-system-modules) (modules '((guix build ant-build-system) + (guix build java-utils) (guix build utils)))) "Build SOURCE with INPUTS." (define builder diff --git a/guix/build/java-utils.scm b/guix/build/java-utils.scm new file mode 100644 index 0000000000..402d377bf8 --- /dev/null +++ b/guix/build/java-utils.scm @@ -0,0 +1,55 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Hartmut Goebel +;;; Copyright © 2016 Ricardo Wurmus +;;; +;;; 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 . + +(define-module (guix build java-utils) + #:use-module (guix build utils) + #:export (ant-build-javadoc + install-jars + install-javadoc)) + +;; Copied from haskell-build-system.scm +(define (package-name-version store-dir) + "Given a store directory STORE-DIR return 'name-version' of the package." + (let* ((base (basename store-dir))) + (string-drop base (+ 1 (string-index base #\-))))) + +(define* (ant-build-javadoc #:key (target "javadoc") (make-flags '()) + #:allow-other-keys) + (zero? (apply system* `("ant" ,target ,@make-flags)))) + +(define* (install-jars jar-directory) + "Install jar files from JAR-DIRECTORY to the default target directory. This +is used in case the build.xml does not include an install target." + (lambda* (#:key outputs #:allow-other-keys) + (let ((share (string-append (assoc-ref outputs "out") + "/share/java"))) + (for-each (lambda (f) (install-file f share)) + (find-files jar-directory "\\.jar$")) + #t))) + +(define* (install-javadoc apidoc-directory) + "Install the APIDOC-DIRECTORY to the target directory. This is used to +install javadocs when this is not done by the install target." + (lambda* (#:key outputs #:allow-other-keys) + (let* ((out (assoc-ref outputs "out")) + (docs (string-append (or (assoc-ref outputs "doc") out) + "/share/doc/" (package-name-version out) "/"))) + (mkdir-p docs) + (copy-recursively apidoc-directory docs) + #t))) -- cgit v1.2.3 From c6cfec42b089ee7d5663b2193eea33d3de49dad2 Mon Sep 17 00:00:00 2001 From: Ben Woodcroft Date: Mon, 2 Jan 2017 22:23:34 +1000 Subject: build-system: Add package-with-ocaml4.01. * guix/build-system/ocaml.scm (default-ocaml4.01, default-ocaml4.01-findlib, package-with-explicit-ocaml, package-with-ocaml4.01, strip-ocaml4.01-variant): New variables. --- guix/build-system/ocaml.scm | 76 ++++++++++++++++++++++++++++++++++++++++++++- 1 file changed, 75 insertions(+), 1 deletion(-) (limited to 'guix/build-system') diff --git a/guix/build-system/ocaml.scm b/guix/build-system/ocaml.scm index f4f57b5ad5..34a22ecffa 100644 --- a/guix/build-system/ocaml.scm +++ b/guix/build-system/ocaml.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Julien Lepiller +;;; Copyright © 2017 Ben Woodcroft ;;; ;;; This file is part of GNU Guix. ;;; @@ -15,7 +16,6 @@ ;;; ;;; You should have received a copy of the GNU General Public License ;;; along with GNU Guix. If not, see . - (define-module (guix build-system ocaml) #:use-module (guix store) #:use-module (guix utils) @@ -25,7 +25,10 @@ #:use-module (guix build-system gnu) #:use-module (guix packages) #:use-module (ice-9 match) + #:use-module (srfi srfi-1) #:export (%ocaml-build-system-modules + package-with-ocaml4.01 + strip-ocaml4.01-variant ocaml-build ocaml-build-system)) @@ -71,6 +74,77 @@ (let ((module (resolve-interface '(gnu packages ocaml)))) (module-ref module 'ocaml-findlib))) +(define (default-ocaml4.01) + (let ((ocaml (resolve-interface '(gnu packages ocaml)))) + (module-ref ocaml 'ocaml-4.01))) + +(define (default-ocaml4.01-findlib) + (let ((module (resolve-interface '(gnu packages ocaml)))) + (module-ref module 'ocaml4.01-findlib))) + +(define* (package-with-explicit-ocaml ocaml findlib old-prefix new-prefix + #:key variant-property) + "Return a procedure of one argument, P. The procedure creates a package +with the same fields as P, which is assumed to use OCAML-BUILD-SYSTEM, such +that it is compiled with OCAML and FINDLIB instead. The inputs are changed +recursively accordingly. If the name of P starts with OLD-PREFIX, this is +replaced by NEW-PREFIX; otherwise, NEW-PREFIX is prepended to the name. + +When VARIANT-PROPERTY is present, it is used as a key to search for +pre-defined variants of this transformation recorded in the 'properties' field +of packages. The property value must be the promise of a package. This is a +convenient way for package writers to force the transformation to use +pre-defined variants." + (define package-variant + (if variant-property + (lambda (package) + (assq-ref (package-properties package) + variant-property)) + (const #f))) + + (define (transform p) + (cond + ;; If VARIANT-PROPERTY is present, use that. + ((package-variant p) + => force) + + ;; Otherwise build the new package object graph. + ((eq? (package-build-system p) ocaml-build-system) + (package + (inherit p) + (location (package-location p)) + (name (let ((name (package-name p))) + (string-append new-prefix + (if (string-prefix? old-prefix name) + (substring name + (string-length old-prefix)) + name)))) + (arguments + (let ((ocaml (if (promise? ocaml) (force ocaml) ocaml)) + (findlib (if (promise? findlib) (force findlib) findlib))) + (ensure-keyword-arguments (package-arguments p) + `(#:ocaml ,ocaml + #:findlib ,findlib)))))) + (else p))) + + (define (cut? p) + (or (not (eq? (package-build-system p) ocaml-build-system)) + (package-variant p))) + + (package-mapping transform cut?)) + +(define package-with-ocaml4.01 + (package-with-explicit-ocaml (delay (default-ocaml4.01)) + (delay (default-ocaml4.01-findlib)) + "ocaml-" "ocaml4.01-" + #:variant-property 'ocaml4.01-variant)) + +(define (strip-ocaml4.01-variant p) + "Remove the 'ocaml4.01-variant' property from P." + (package + (inherit p) + (properties (alist-delete 'ocaml4.01-variant (package-properties p))))) + (define* (lower name #:key source inputs native-inputs outputs system target (ocaml (default-ocaml)) -- cgit v1.2.3 From 35189728cdee8a3755640a82c0094507c7fcfc76 Mon Sep 17 00:00:00 2001 From: Andy Patterson Date: Mon, 3 Apr 2017 09:01:23 -0400 Subject: build-system/asdf: Use asdf to determine dependencies. This removes the need for conventions to determine which inputs are run-time dependencies, and also the need to specify "special" dependencies. * guix/build/lisp-utils.scm (patch-asd-file, lisp-dependencies) (wrap-perform-method): Remove them. (inputs->asd-file-map, system-dependencies, generate-system-definition) (generate-dependency-links, make-asd-file): New procedures. (lisp-eval-program): Add an error if no lisp matches. (compile-system): Don't use asdf's in-built asd-file generator. --- gnu/packages/lisp.scm | 5 +- guix/build-system/asdf.scm | 7 +- guix/build/asdf-build-system.scm | 51 +++++------ guix/build/lisp-utils.scm | 185 ++++++++++++++++++++++++++------------- 4 files changed, 145 insertions(+), 103 deletions(-) (limited to 'guix/build-system') diff --git a/gnu/packages/lisp.scm b/gnu/packages/lisp.scm index c395effd1c..ca83ec9977 100644 --- a/gnu/packages/lisp.scm +++ b/gnu/packages/lisp.scm @@ -822,8 +822,6 @@ compatible with ANSI-compliant Common Lisp implementations.") (substitute* "clx.asd" (("\\(:file \"trapezoid\"\\)") "")))))) (build-system asdf-build-system/sbcl) - (arguments - '(#:special-dependencies '("sb-bsd-sockets"))) (home-page "http://www.cliki.net/portable-clx") (synopsis "X11 client library for Common Lisp") (description "CLX is an X11 client library for Common Lisp. The code was @@ -855,8 +853,7 @@ from other CLXes around the net.") ("sbcl-clx" ,sbcl-clx))) (outputs '("out" "lib")) (arguments - '(#:special-dependencies '("sb-posix") - #:phases + '(#:phases (modify-phases %standard-phases (add-after 'create-symlinks 'build-program (lambda* (#:key lisp outputs inputs #:allow-other-keys) diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index f28c098ea2..4b5af95c9a 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -194,8 +194,7 @@ set up using CL source package conventions." (define base-arguments (if target-is-source? (strip-keyword-arguments - '(#:tests? #:special-dependencies #:asd-file - #:test-only-systems #:lisp) + '(#:tests? #:asd-file #:lisp) (package-arguments pkg)) (package-arguments pkg))) @@ -262,9 +261,7 @@ set up using CL source package conventions." (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)) @@ -284,9 +281,7 @@ set up using CL source package conventions." ((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 diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index 10873e98d9..a16f11965d 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -21,6 +21,7 @@ #:use-module (guix build utils) #:use-module (guix build lisp-utils) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-26) #:use-module (ice-9 rdelim) #:use-module (ice-9 receive) @@ -161,31 +162,25 @@ valid." (format #t "test suite not run~%"))) #t) -(define* (patch-asd-files #:key outputs +(define* (create-asd-file #:key outputs inputs lisp - special-dependencies - test-only-systems + asd-file #:allow-other-keys) - "Patch any asd files created by the compilation process so that they can -find their dependencies. Exclude any TEST-ONLY-SYSTEMS which were only -included to run tests. Add any SPECIAL-DEPENDENCIES which the LISP -implementation itself provides." - (let* ((out (library-output outputs)) - (name (remove-lisp-from-name (output-path->package-name out) lisp)) - (registry (lset-difference - (lambda (input system) - (match input - ((name . path) (string=? name system)))) - (lisp-dependencies lisp inputs) - test-only-systems)) - (lisp-systems (map first registry))) - - (for-each - (lambda (asd-file) - (patch-asd-file asd-file registry lisp - (append lisp-systems special-dependencies))) - (find-files out "\\.asd$"))) + "Create a system definition file for the built system." + (let*-values (((out) (library-output outputs)) + ((full-name version) (package-name->name+version + (strip-store-file-name out))) + ((name) (remove-lisp-from-name full-name lisp)) + ((new-asd-file) (string-append (library-directory out lisp) + "/" name ".asd"))) + + (make-asd-file new-asd-file + #:lisp lisp + #:system name + #:version version + #:inputs inputs + #:system-asd-file asd-file)) #t) (define* (symlink-asd-files #:key outputs lisp #:allow-other-keys) @@ -193,9 +188,6 @@ implementation itself provides." (let* ((out (library-output outputs))) (for-each (lambda (asd-file) - (substitute* asd-file - ((";;; Built for.*") "") ; remove potential non-determinism - (("^\\(DEFSYSTEM(.*)$" all end) (string-append "(asdf:defsystem" end))) (receive (new-asd-file asd-file-directory) (bundle-asd-file out asd-file lisp) (mkdir-p asd-file-directory) @@ -205,12 +197,11 @@ implementation itself provides." (prepend-to-source-registry (string-append asd-file-directory "/")))) - (find-files (string-append out %object-prefix) "\\.asd$")) -) + (find-files (string-append out %object-prefix) "\\.asd$"))) #t) (define* (cleanup-files #:key outputs lisp - #:allow-other-keys) + #:allow-other-keys) "Remove any compiled files which are not a part of the final bundle." (let ((out (library-output outputs))) (match lisp @@ -261,8 +252,8 @@ implementation itself provides." (add-before 'build 'copy-source copy-source) (replace 'check check) (replace 'strip strip) - (add-after 'check 'link-dependencies patch-asd-files) - (add-after 'link-dependencies 'cleanup cleanup-files) + (add-after 'check 'create-asd-file create-asd-file) + (add-after 'create-asd-file 'cleanup cleanup-files) (add-after 'cleanup 'create-symlinks symlink-asd-files))) (define* (asdf-build #:key inputs diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 47399bc187..4f1565b55c 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -18,6 +18,7 @@ (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) @@ -32,15 +33,14 @@ generate-executable-wrapper-system generate-executable-entry-point generate-executable-for-system - patch-asd-file bundle-install-prefix - lisp-dependencies bundle-asd-file remove-lisp-from-name wrap-output-translations prepend-to-source-registry build-program - build-image)) + build-image + make-asd-file)) ;;; Commentary: ;;; @@ -64,6 +64,23 @@ (define (remove-lisp-from-name name lisp) (string-drop name (1+ (string-length lisp)))) +(define (inputs->asd-file-map inputs lisp) + "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 lisp)))) + (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 @@ -80,7 +97,8 @@ with PROGRAM." (match lisp ("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program)) - ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)")))) + ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)")) + (_ (error "The LISP provided is not supported at this time.")))) (define (asdf-load-all systems) (map (lambda (system) @@ -108,15 +126,61 @@ first if SYSTEM is defined there." (find-symbol (symbol-name :compile-bundle-op) (symbol-name :asdf)) - ,system) - (funcall (find-symbol - (symbol-name :operate) - (symbol-name :asdf)) - (find-symbol - (symbol-name :deliver-asd-op) - (symbol-name :asdf)) ,system)))) +(define (system-dependencies lisp system asd-file) + "Return the dependencies of SYSTEM, as reported by +asdf:system-depends-on. First load the system's ASD-FILE, if necessary." + (define deps-file ".deps.sexp") + (define program + `(progn + (require :asdf) + ,@(if asd-file + `((let ((*package* (find-package :asdf))) + (load ,asd-file))) + '()) + (with-open-file + (stream ,deps-file :direction :output) + (format stream + "~s~%" + (funcall + (find-symbol + (symbol-name :system-depends-on) + (symbol-name :asdf)) + + (funcall + (find-symbol + (symbol-name :find-system) + (symbol-name :asdf)) + + ,system)))))) + + (dynamic-wind + (lambda _ + (lisp-eval-program lisp program)) + (lambda _ + (call-with-input-file deps-file read)) + (lambda _ + (when (file-exists? deps-file) + (delete-file deps-file))))) + +(define (compiled-system system lisp) + (match lisp + ("sbcl" (string-append system "--system")) + (_ system))) + +(define* (generate-system-definition lisp system + #:key version dependencies) + `(asdf:defsystem + ,system + :class asdf/bundle:prebuilt-system + :version ,version + :depends-on ,dependencies + :components ((:compiled-file ,(compiled-system system lisp))) + ,@(if (string=? "ecl" lisp) + `(:lib ,(string-append system ".a")) + '()))) + (define (test-system system lisp asd-file) "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first if SYSTEM is defined there." @@ -185,58 +249,53 @@ ENTRY-PROGRAM for SYSTEM within the current directory." (declare (ignorable arguments)) ,@entry-program)))))))) -(define (wrap-perform-method lisp registry dependencies file-name) - "Creates a wrapper method which allows the system to locate its dependent -systems from REGISTRY, an alist of the same form as %outputs, which contains -lisp systems which the systems is dependent on. All DEPENDENCIES which the -system depends on will the be loaded before this system." - (let* ((system (string-drop-right (basename file-name) 4)) - (system-symbol (string->lisp-keyword system))) - - `(defmethod asdf:perform :before - (op (c (eql (asdf:find-system ,system-symbol)))) - (asdf/source-registry:ensure-source-registry) - ,@(map (match-lambda - ((name . path) - (let ((asd-file (string-append path - (bundle-install-prefix lisp) - "/" name ".asd"))) - `(setf - (gethash ,name - asdf/source-registry:*source-registry*) - ,(string->symbol "#p") - ,(bundle-asd-file path asd-file lisp))))) - registry) - ,@(map (lambda (system) - `(asdf:load-system ,(string->lisp-keyword system))) - dependencies)))) - -(define (patch-asd-file asd-file registry lisp dependencies) - "Patches ASD-FILE with a perform method as described in WRAP-PERFORM-METHOD." - (chmod asd-file #o644) - (let ((port (open-file asd-file "a"))) - (dynamic-wind - (lambda _ #t) - (lambda _ - (display - (replace-escaped-macros - (format #f "~%~y~%" - (wrap-perform-method lisp registry - dependencies asd-file))) - port)) - (lambda _ (close-port port)))) - (chmod asd-file #o444)) - -(define (lisp-dependencies lisp inputs) - "Determine which inputs are lisp system dependencies, by using the convention -that a lisp system dependency will resemble \"system-LISP\"." - (filter-map (match-lambda - ((name . value) - (and (string-prefix? lisp name) - (string<> lisp name) - `(,(remove-lisp-from-name name lisp) - . ,value)))) - inputs)) +(define (generate-dependency-links lisp 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 lisp 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 + (parameterize ((%lisp (string-append (assoc-ref inputs lisp) "/bin/" lisp))) + (system-dependencies lisp system system-asd-file))) + + (define lisp-input-map + (inputs->asd-file-map inputs lisp)) + + (define registry + (filter-map hash-get-handle + (make-list (if (eq? 'NIL dependencies) + 0 + (length dependencies)) + lisp-input-map) + (if (eq? 'NIL dependencies) + '() + dependencies))) + + (call-with-output-file asd-file + (lambda (port) + (display + (replace-escaped-macros + (format #f "~y~%~y~%" + (generate-system-definition lisp system + #:version version + #:dependencies dependencies) + (generate-dependency-links lisp registry system))) + port)))) (define (bundle-asd-file output-path original-asd-file lisp) "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking in -- cgit v1.2.3 From 0e1371be09fc487db2a9245be7499cf91670a922 Mon Sep 17 00:00:00 2001 From: Andy Patterson Date: Mon, 3 Apr 2017 09:01:24 -0400 Subject: build-system/asdf: Don't rename inputs. * guix/build-system/asdf.scm (package-with-build-system)[transform]: Use updated `new-inputs' procedure for inputs and native-inputs. : Don't rename inputs. : Draw from package-inputs and package-native-inputs for source packages. Use the original package's propagated-inputs otherwise. : Convert into a function to be used to transform inputs and native-inputs. * gnu/packages/lisp.scm (sbcl-fiveam, sbcl-bordeaux-threads) (sbcl-flexi-streams, sbcl-cl-ppcre, sbcl-stumpwm, sbcl-slynk-arglists) (sbcl-slynk-fancy-inspector): Don't prefix input names. --- gnu/packages/lisp.scm | 18 +++++++++--------- guix/build-system/asdf.scm | 44 ++++++++++++++++++++++---------------------- 2 files changed, 31 insertions(+), 31 deletions(-) (limited to 'guix/build-system') diff --git a/gnu/packages/lisp.scm b/gnu/packages/lisp.scm index ca83ec9977..d8d858928a 100644 --- a/gnu/packages/lisp.scm +++ b/gnu/packages/lisp.scm @@ -659,7 +659,7 @@ portable between implementations.") (sha256 (base32 "0f48pcbhqs3wwwzjl5nk57d4hcbib4l9xblxc66b8c2fhvhmhxnv")) (file-name (string-append "fiveam-" version ".tar.gz")))) - (inputs `(("sbcl-alexandria" ,sbcl-alexandria))) + (inputs `(("alexandria" ,sbcl-alexandria))) (build-system asdf-build-system/sbcl) (synopsis "Common Lisp testing framework") (description "FiveAM is a simple (as far as writing and running tests @@ -687,8 +687,8 @@ interactive development model in mind.") (base32 "10ryrcx832fwqdawb6jmknymi7wpdzhi30qzx7cbrk0cpnka71w2")) (file-name (string-append "bordeaux-threads-" version ".tar.gz")))) - (inputs `(("sbcl-alexandria" ,sbcl-alexandria))) - (native-inputs `(("tests:cl-fiveam" ,sbcl-fiveam))) + (inputs `(("alexandria" ,sbcl-alexandria))) + (native-inputs `(("fiveam" ,sbcl-fiveam))) (build-system asdf-build-system/sbcl) (synopsis "Portable shared-state concurrency library for Common Lisp") (description "BORDEAUX-THREADS is a proposed standard for a minimal @@ -749,7 +749,7 @@ thin compatibility layer for gray streams.") (base32 "16grnxvs7vqm5s6myf8a5s7vwblzq1kgwj8i7ahz8vwvihm9gzfi")) (file-name (string-append "flexi-streams-" version ".tar.gz")))) (build-system asdf-build-system/sbcl) - (inputs `(("sbcl-trivial-gray-streams" ,sbcl-trivial-gray-streams))) + (inputs `(("trivial-gray-streams" ,sbcl-trivial-gray-streams))) (synopsis "Implementation of virtual bivalent streams for Common Lisp") (description "Flexi-streams is an implementation of \"virtual\" bivalent streams that can be layered atop real binary or bivalent streams and that can @@ -779,7 +779,7 @@ streams which are similar to string streams.") (base32 "1i7daxf0wnydb0pgwiym7qh2wy70n14lxd6dyv28sy0naa8p31gd")) (file-name (string-append "cl-ppcre-" version ".tar.gz")))) (build-system asdf-build-system/sbcl) - (native-inputs `(("tests:cl-flexi-streams" ,sbcl-flexi-streams))) + (native-inputs `(("flexi-streams" ,sbcl-flexi-streams))) (synopsis "Portable regular expression library for Common Lisp") (description "CL-PPCRE is a portable regular expression library for Common Lisp, which is compatible with perl. It is pretty fast, thread-safe, and @@ -849,8 +849,8 @@ from other CLXes around the net.") (base32 "1maxp98gh64az3d9vz9br6zdd6rc9fmj2imvax4by85g6kxvdz1i")) (file-name (string-append "stumpwm-" version ".tar.gz")))) (build-system asdf-build-system/sbcl) - (inputs `(("sbcl-cl-ppcre" ,sbcl-cl-ppcre) - ("sbcl-clx" ,sbcl-clx))) + (inputs `(("cl-ppcre" ,sbcl-cl-ppcre) + ("clx" ,sbcl-clx))) (outputs '("out" "lib")) (arguments '(#:phases @@ -968,7 +968,7 @@ multiple inspectors with independent history.") (package (inherit sbcl-slynk-boot0) (name "sbcl-slynk-arglists") - (inputs `(("sbcl-slynk" ,sbcl-slynk-boot0))) + (inputs `(("slynk" ,sbcl-slynk-boot0))) (arguments `(#:asd-file "slynk.asd" ,@(package-arguments sbcl-slynk-boot0))))) @@ -988,7 +988,7 @@ multiple inspectors with independent history.") (package (inherit sbcl-slynk-arglists) (name "sbcl-slynk-fancy-inspector") - (inputs `(("sbcl-slynk-util" ,sbcl-slynk-util) + (inputs `(("slynk-util" ,sbcl-slynk-util) ,@(package-inputs sbcl-slynk-arglists))))) (define ecl-slynk-fancy-inspector diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index 4b5af95c9a..d02565b2d1 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 +;;; Copyright © 2016, 2017 Andy Patterson ;;; ;;; This file is part of GNU Guix. ;;; @@ -163,33 +163,35 @@ 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? @@ -212,11 +214,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))))) -- cgit v1.2.3 From 6de91ba2a14fd5c15721d87b63e7f8ab52a29a67 Mon Sep 17 00:00:00 2001 From: Andy Patterson Date: Mon, 3 Apr 2017 09:01:26 -0400 Subject: build-system/asdf: Make #:lisp a package argument. * guix/build-system/asdf.scm (lower): Change argument name to `lisp-type'. (asdf-build): Change argument name to `lisp-type'. Remove `lisp' as an argument to the returned procedure. Change the argument passed to build phases to `lisp-type'. * guix/build/asdf-build-system.scm (copy-source, build, check) (create-asd-file, symlink-asd-files, cleanup-files, strip): Respect `lisp-type` argument. * gnu/packages/lisp.scm (sbcl-stumpwm, sbcl-stumpwm+slynk): Likewise. --- gnu/packages/lisp.scm | 8 +++--- guix/build-system/asdf.scm | 13 +++++----- guix/build/asdf-build-system.scm | 56 +++++++++++++++++++++------------------- 3 files changed, 40 insertions(+), 37 deletions(-) (limited to 'guix/build-system') diff --git a/gnu/packages/lisp.scm b/gnu/packages/lisp.scm index d8d858928a..aedb24587f 100644 --- a/gnu/packages/lisp.scm +++ b/gnu/packages/lisp.scm @@ -856,9 +856,9 @@ from other CLXes around the net.") '(#:phases (modify-phases %standard-phases (add-after 'create-symlinks 'build-program - (lambda* (#:key lisp outputs inputs #:allow-other-keys) + (lambda* (#:key lisp-type outputs inputs #:allow-other-keys) (build-program - lisp + lisp-type (string-append (assoc-ref outputs "out") "/bin/stumpwm") #:inputs inputs #:entry-program '((stumpwm:stumpwm) 0)))) @@ -1145,10 +1145,10 @@ multiple inspectors with independent history.") ((#:phases phases) `(modify-phases ,phases (replace 'build-program - (lambda* (#:key lisp inputs outputs #:allow-other-keys) + (lambda* (#:key lisp-type inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (program (string-append out "/bin/stumpwm"))) - (build-program lisp program + (build-program lisp-type program #:inputs inputs #:entry-program '((stumpwm:stumpwm) 0) #:dependencies '("stumpwm" diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index d02565b2d1..1ef6f32d4c 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -232,10 +232,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" @@ -251,18 +251,17 @@ 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) (asd-file #f) - (lisp lisp-implementation) (phases '(@ (guix build asdf-build-system) %standard-phases)) (search-paths '()) @@ -280,7 +279,7 @@ set up using CL source package conventions." (derivation->output-path source)) ((source) source) (source source)) - #:lisp ,lisp + #:lisp-type ,lisp-type #:asd-file ,asd-file #:system ,system #:tests? ,tests? diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index 2efd164307..c5f2c080dc 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -104,29 +104,32 @@ valid." "Copy and symlink all the source files." (copy-files-to-output (assoc-ref outputs "out") (outputs->name outputs))) -(define* (copy-source #:key outputs lisp #:allow-other-keys) +(define* (copy-source #:key outputs lisp-type #:allow-other-keys) "Copy the source to the library output." (let* ((out (library-output outputs)) - (name (remove-lisp-from-name (output-path->package-name out) lisp)) + (name (remove-lisp-from-name (output-path->package-name out) + lisp-type)) (install-path (string-append out %source-install-prefix))) (copy-files-to-output out name) ;; Hide the files from asdf (with-directory-excursion install-path - (rename-file "source" (string-append lisp "-source")) + (rename-file "source" (string-append lisp-type "-source")) (delete-file-recursively "systems"))) #t) -(define* (build #:key outputs inputs lisp asd-file +(define* (build #:key outputs inputs lisp-type asd-file #:allow-other-keys) "Compile the system." (let* ((out (library-output outputs)) - (name (remove-lisp-from-name (output-path->package-name out) lisp)) - (source-path (lisp-source-directory out lisp name)) + (name (remove-lisp-from-name (output-path->package-name out) + lisp-type)) + (source-path (lisp-source-directory out lisp-type name)) (translations (wrap-output-translations `(,(output-translation source-path out - lisp)))) - (asd-file (and=> asd-file (cut source-asd-file out lisp name <>)))) + lisp-type)))) + (asd-file (and=> asd-file + (cut source-asd-file out lisp-type name <>)))) (setenv "ASDF_OUTPUT_TRANSLATIONS" (replace-escaped-macros (format #f "~S" translations))) @@ -139,8 +142,8 @@ valid." (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache (parameterize ((%lisp (string-append - (assoc-ref inputs lisp) "/bin/" lisp))) - (compile-system name lisp asd-file)) + (assoc-ref inputs lisp-type) "/bin/" lisp-type))) + (compile-system name lisp-type asd-file)) ;; As above, ecl will sometimes create this even though it doesn't use it @@ -149,47 +152,48 @@ valid." (delete-file-recursively cache-directory)))) #t) -(define* (check #:key lisp tests? outputs inputs asd-file +(define* (check #:key lisp-type tests? outputs inputs asd-file #:allow-other-keys) "Test the system." - (let* ((name (remove-lisp-from-name (outputs->name outputs) lisp)) + (let* ((name (remove-lisp-from-name (outputs->name outputs) lisp-type)) (out (library-output outputs)) - (asd-file (and=> asd-file (cut source-asd-file out lisp name <>)))) + (asd-file (and=> asd-file + (cut source-asd-file out lisp-type name <>)))) (if tests? (parameterize ((%lisp (string-append - (assoc-ref inputs lisp) "/bin/" lisp))) - (test-system name lisp asd-file)) + (assoc-ref inputs lisp-type) "/bin/" lisp-type))) + (test-system name lisp-type asd-file)) (format #t "test suite not run~%"))) #t) (define* (create-asd-file #:key outputs inputs - lisp + lisp-type asd-file #:allow-other-keys) "Create a system definition file for the built system." (let*-values (((out) (library-output outputs)) ((full-name version) (package-name->name+version (strip-store-file-name out))) - ((name) (remove-lisp-from-name full-name lisp)) - ((new-asd-file) (string-append (library-directory out lisp) + ((name) (remove-lisp-from-name full-name lisp-type)) + ((new-asd-file) (string-append (library-directory out lisp-type) "/" name ".asd"))) (make-asd-file new-asd-file - #:lisp lisp + #:lisp lisp-type #:system name #:version version #:inputs inputs #:system-asd-file asd-file)) #t) -(define* (symlink-asd-files #:key outputs lisp #:allow-other-keys) +(define* (symlink-asd-files #:key outputs lisp-type #:allow-other-keys) "Create an extra reference to the system in a convenient location." (let* ((out (library-output outputs))) (for-each (lambda (asd-file) (receive (new-asd-file asd-file-directory) - (bundle-asd-file out asd-file lisp) + (bundle-asd-file out asd-file lisp-type) (mkdir-p asd-file-directory) (symlink asd-file new-asd-file) ;; Update the source registry for future phases which might want to @@ -200,11 +204,11 @@ valid." (find-files (string-append out %object-prefix) "\\.asd$"))) #t) -(define* (cleanup-files #:key outputs lisp +(define* (cleanup-files #:key outputs lisp-type #:allow-other-keys) "Remove any compiled files which are not a part of the final bundle." (let ((out (library-output outputs))) - (match lisp + (match lisp-type ("sbcl" (for-each (lambda (file) @@ -216,7 +220,7 @@ valid." (append (find-files out "\\.fas$") (find-files out "\\.o$"))))) - (with-directory-excursion (library-directory out lisp) + (with-directory-excursion (library-directory out lisp-type) (for-each (lambda (file) (rename-file file @@ -231,9 +235,9 @@ valid." (string<> ".." file))))))) #t) -(define* (strip #:key lisp #:allow-other-keys #:rest args) +(define* (strip #:key lisp-type #:allow-other-keys #:rest args) ;; stripping sbcl binaries removes their entry program and extra systems - (or (string=? lisp "sbcl") + (or (string=? lisp-type "sbcl") (apply (assoc-ref gnu:%standard-phases 'strip) args))) (define %standard-phases/source -- cgit v1.2.3 From b4c9f0c50de39da253dadfde9e85de06d665cd1e Mon Sep 17 00:00:00 2001 From: Andy Patterson Date: Mon, 3 Apr 2017 09:01:27 -0400 Subject: build-system/asdf: Parameterize the lisp type and implementation globally. * guix/build-system/asdf.scm (asdf-build)[builder]: Parameterize %lisp-type and %lisp before invoking the build procedure. Don't pass #:lisp-type as an argument to said procedure. * guix/build/asdf-build-system.scm: Adjust accordingly. (source-install-prefix): Rename to %lisp-source-install-prefix. * guix/build/lisp-utils.scm: Adjust accordingly. (%lisp-type): New parameter. (bundle-install-prefix): Rename to %bundle-install-prefix. * gnu/packages/lisp.scm: Adjust accordingly. --- gnu/packages/lisp.scm | 23 ++++--- guix/build-system/asdf.scm | 33 +++++----- guix/build/asdf-build-system.scm | 74 ++++++++++----------- guix/build/lisp-utils.scm | 135 +++++++++++++++++++-------------------- 4 files changed, 128 insertions(+), 137 deletions(-) (limited to 'guix/build-system') diff --git a/gnu/packages/lisp.scm b/gnu/packages/lisp.scm index aedb24587f..ed8a043583 100644 --- a/gnu/packages/lisp.scm +++ b/gnu/packages/lisp.scm @@ -856,11 +856,9 @@ from other CLXes around the net.") '(#:phases (modify-phases %standard-phases (add-after 'create-symlinks 'build-program - (lambda* (#:key lisp-type outputs inputs #:allow-other-keys) + (lambda* (#:key outputs #:allow-other-keys) (build-program - lisp-type (string-append (assoc-ref outputs "out") "/bin/stumpwm") - #:inputs inputs #:entry-program '((stumpwm:stumpwm) 0)))) (add-after 'build-program 'create-desktop-file (lambda* (#:key outputs #:allow-other-keys) @@ -1103,12 +1101,14 @@ multiple inspectors with independent history.") (prepend-to-source-registry (string-append (assoc-ref %outputs "out") "//")) - (build-image "sbcl" - (string-append - (assoc-ref %outputs "image") - "/bin/slynk") - #:inputs %build-inputs - #:dependencies ',slynk-systems)))))) + + (parameterize ((%lisp-type "sbcl") + (%lisp (string-append (assoc-ref %build-inputs "sbcl") + "/bin/sbcl"))) + (build-image (string-append + (assoc-ref %outputs "image") + "/bin/slynk") + #:dependencies ',slynk-systems))))))) (define-public ecl-slynk (package @@ -1145,11 +1145,10 @@ multiple inspectors with independent history.") ((#:phases phases) `(modify-phases ,phases (replace 'build-program - (lambda* (#:key lisp-type inputs outputs #:allow-other-keys) + (lambda* (#:key outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (program (string-append out "/bin/stumpwm"))) - (build-program lisp-type program - #:inputs inputs + (build-program program #:entry-program '((stumpwm:stumpwm) 0) #:dependencies '("stumpwm" ,@slynk-systems)) diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index 1ef6f32d4c..4afc6ef1a7 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -273,21 +273,24 @@ set up using CL source package conventions." (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-type ,lisp-type - #:asd-file ,asd-file - #: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 ,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 diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index c5f2c080dc..4305a86af9 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -43,8 +43,8 @@ (define %object-prefix "/lib") -(define (source-install-prefix lisp) - (string-append %source-install-prefix "/" lisp "-source")) +(define (%lisp-source-install-prefix) + (string-append %source-install-prefix "/" (%lisp-type) "-source")) (define %system-install-prefix (string-append %source-install-prefix "/systems")) @@ -56,28 +56,27 @@ (output-path->package-name (assoc-ref outputs "out"))) -(define (lisp-source-directory output lisp name) - (string-append output (source-install-prefix lisp) "/" name)) +(define (lisp-source-directory output name) + (string-append output (%lisp-source-install-prefix) "/" name)) (define (source-directory output name) (string-append output %source-install-prefix "/source/" name)) -(define (library-directory output lisp) +(define (library-directory output) (string-append output %object-prefix - "/" lisp)) + "/" (%lisp-type))) (define (output-translation source-path - object-output - lisp) + object-output) "Return a translation for the system's source path to it's binary output." `((,source-path :**/ :*.*.*) - (,(library-directory object-output lisp) + (,(library-directory object-output) :**/ :*.*.*))) -(define (source-asd-file output lisp name asd-file) - (string-append (lisp-source-directory output lisp name) "/" asd-file)) +(define (source-asd-file output name asd-file) + (string-append (lisp-source-directory output name) "/" asd-file)) (define (library-output outputs) "If a `lib' output exists, build things there. Otherwise use `out'." @@ -104,32 +103,29 @@ valid." "Copy and symlink all the source files." (copy-files-to-output (assoc-ref outputs "out") (outputs->name outputs))) -(define* (copy-source #:key outputs lisp-type #:allow-other-keys) +(define* (copy-source #:key outputs #:allow-other-keys) "Copy the source to the library output." (let* ((out (library-output outputs)) - (name (remove-lisp-from-name (output-path->package-name out) - lisp-type)) + (name (remove-lisp-from-name (output-path->package-name out))) (install-path (string-append out %source-install-prefix))) (copy-files-to-output out name) ;; Hide the files from asdf (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"))) #t) -(define* (build #:key outputs inputs lisp-type asd-file +(define* (build #:key outputs inputs asd-file #:allow-other-keys) "Compile the system." (let* ((out (library-output outputs)) - (name (remove-lisp-from-name (output-path->package-name out) - lisp-type)) - (source-path (lisp-source-directory out lisp-type name)) + (name (remove-lisp-from-name (output-path->package-name out))) + (source-path (lisp-source-directory out name)) (translations (wrap-output-translations `(,(output-translation source-path - out - lisp-type)))) + out)))) (asd-file (and=> asd-file - (cut source-asd-file out lisp-type name <>)))) + (cut source-asd-file out name <>)))) (setenv "ASDF_OUTPUT_TRANSLATIONS" (replace-escaped-macros (format #f "~S" translations))) @@ -141,9 +137,7 @@ valid." (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache - (parameterize ((%lisp (string-append - (assoc-ref inputs lisp-type) "/bin/" lisp-type))) - (compile-system name lisp-type asd-file)) + (compile-system name asd-file) ;; As above, ecl will sometimes create this even though it doesn't use it @@ -152,48 +146,44 @@ valid." (delete-file-recursively cache-directory)))) #t) -(define* (check #:key lisp-type tests? outputs inputs asd-file +(define* (check #:key tests? outputs inputs asd-file #:allow-other-keys) "Test the system." - (let* ((name (remove-lisp-from-name (outputs->name outputs) lisp-type)) + (let* ((name (remove-lisp-from-name (outputs->name outputs))) (out (library-output outputs)) (asd-file (and=> asd-file - (cut source-asd-file out lisp-type name <>)))) + (cut source-asd-file out name <>)))) (if tests? - (parameterize ((%lisp (string-append - (assoc-ref inputs lisp-type) "/bin/" lisp-type))) - (test-system name lisp-type asd-file)) + (test-system name asd-file) (format #t "test suite not run~%"))) #t) (define* (create-asd-file #:key outputs inputs - lisp-type asd-file #:allow-other-keys) "Create a system definition file for the built system." (let*-values (((out) (library-output outputs)) ((full-name version) (package-name->name+version (strip-store-file-name out))) - ((name) (remove-lisp-from-name full-name lisp-type)) - ((new-asd-file) (string-append (library-directory out lisp-type) + ((name) (remove-lisp-from-name full-name)) + ((new-asd-file) (string-append (library-directory out) "/" name ".asd"))) (make-asd-file new-asd-file - #:lisp lisp-type #:system name #:version version #:inputs inputs #:system-asd-file asd-file)) #t) -(define* (symlink-asd-files #:key outputs lisp-type #:allow-other-keys) +(define* (symlink-asd-files #:key outputs #:allow-other-keys) "Create an extra reference to the system in a convenient location." (let* ((out (library-output outputs))) (for-each (lambda (asd-file) (receive (new-asd-file asd-file-directory) - (bundle-asd-file out asd-file lisp-type) + (bundle-asd-file out asd-file) (mkdir-p asd-file-directory) (symlink asd-file new-asd-file) ;; Update the source registry for future phases which might want to @@ -204,11 +194,11 @@ valid." (find-files (string-append out %object-prefix) "\\.asd$"))) #t) -(define* (cleanup-files #:key outputs lisp-type +(define* (cleanup-files #:key outputs #:allow-other-keys) "Remove any compiled files which are not a part of the final bundle." (let ((out (library-output outputs))) - (match lisp-type + (match (%lisp-type) ("sbcl" (for-each (lambda (file) @@ -220,7 +210,7 @@ valid." (append (find-files out "\\.fas$") (find-files out "\\.o$"))))) - (with-directory-excursion (library-directory out lisp-type) + (with-directory-excursion (library-directory out) (for-each (lambda (file) (rename-file file @@ -235,9 +225,9 @@ valid." (string<> ".." file))))))) #t) -(define* (strip #:key lisp-type #:allow-other-keys #:rest args) +(define* (strip #:rest args) ;; stripping sbcl binaries removes their entry program and extra systems - (or (string=? lisp-type "sbcl") + (or (string=? (%lisp-type) "sbcl") (apply (assoc-ref gnu:%standard-phases 'strip) args))) (define %standard-phases/source diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 4f1565b55c..148357bf0e 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -25,6 +25,7 @@ #:use-module (srfi srfi-26) #:use-module (guix build utils) #:export (%lisp + %lisp-type %source-install-prefix lisp-eval-program compile-system @@ -33,7 +34,7 @@ generate-executable-wrapper-system generate-executable-entry-point generate-executable-for-system - bundle-install-prefix + %bundle-install-prefix bundle-asd-file remove-lisp-from-name wrap-output-translations @@ -54,24 +55,28 @@ ;; 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 lisp) - (string-append %source-install-prefix "/" lisp "-bundle-systems")) +(define (%bundle-install-prefix) + (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 lisp) +(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 lisp)))) + (let ((prefix (string-append path (%bundle-install-prefix)))) (and (directory-exists? prefix) (match (find-files prefix "\\.asd$") ((asd-file) @@ -86,16 +91,16 @@ name of an ASD system, and asd-file is the full path to its definition." ,@translations :inherit-configuration)) -(define (lisp-eval-program lisp program) +(define (lisp-eval-program program) "Evaluate PROGRAM with a given LISP implementation." (unless (zero? (apply system* - (lisp-invoke lisp (format #f "~S" program)))) - (error "lisp-eval-program failed!" lisp program))) + (lisp-invoke (format #f "~S" program)))) + (error "lisp-eval-program failed!" (%lisp) program))) -(define (lisp-invoke lisp program) +(define (lisp-invoke program) "Return a list of arguments for system* determining how to invoke LISP with PROGRAM." - (match lisp + (match (%lisp-type) ("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program)) ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)")) (_ (error "The LISP provided is not supported at this time.")))) @@ -109,26 +114,26 @@ with PROGRAM." ,system)) systems)) -(define (compile-system system lisp asd-file) +(define (compile-system system asd-file) "Use a lisp implementation to compile SYSTEM using asdf. Load ASD-FILE first if SYSTEM is defined there." - (lisp-eval-program lisp - `(progn - (require :asdf) - (in-package :asdf) - ,@(if asd-file - `((load ,asd-file)) - '()) - (in-package :cl-user) - (funcall (find-symbol - (symbol-name :operate) - (symbol-name :asdf)) - (find-symbol - (symbol-name :compile-bundle-op) - (symbol-name :asdf)) - ,system)))) - -(define (system-dependencies lisp system asd-file) + (lisp-eval-program + `(progn + (require :asdf) + (in-package :asdf) + ,@(if asd-file + `((load ,asd-file)) + '()) + (in-package :cl-user) + (funcall (find-symbol + (symbol-name :operate) + (symbol-name :asdf)) + (find-symbol + (symbol-name :compile-bundle-op) + (symbol-name :asdf)) + ,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, if necessary." (define deps-file ".deps.sexp") @@ -157,56 +162,55 @@ asdf:system-depends-on. First load the system's ASD-FILE, if necessary." (dynamic-wind (lambda _ - (lisp-eval-program lisp program)) + (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 lisp) - (match lisp +(define (compiled-system system) + (match (%lisp-type) ("sbcl" (string-append system "--system")) (_ system))) -(define* (generate-system-definition lisp system +(define* (generate-system-definition system #:key version dependencies) `(asdf:defsystem ,system :class asdf/bundle:prebuilt-system :version ,version :depends-on ,dependencies - :components ((:compiled-file ,(compiled-system system lisp))) - ,@(if (string=? "ecl" lisp) + :components ((:compiled-file ,(compiled-system system))) + ,@(if (string=? "ecl" (%lisp-type)) `(:lib ,(string-append system ".a")) '()))) -(define (test-system system lisp asd-file) +(define (test-system system asd-file) "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first if SYSTEM is defined there." - (lisp-eval-program lisp - `(progn - (require :asdf) - (in-package :asdf) - ,@(if asd-file - `((load ,asd-file)) - '()) - (in-package :cl-user) - (funcall (find-symbol - (symbol-name :test-system) - (symbol-name :asdf)) - ,system)))) + (lisp-eval-program + `(progn + (require :asdf) + (in-package :asdf) + ,@(if asd-file + `((load ,asd-file)) + '()) + (in-package :cl-user) + (funcall (find-symbol + (symbol-name :test-system) + (symbol-name :asdf)) + ,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 lisp) +(define (generate-executable-for-system type system) "Use LISP to generate an executable, whose TYPE can be \"image\" or \"program\". The latter will always be standalone. Depends on having created a \"SYSTEM-exec\" system which contains the entry program." (lisp-eval-program - lisp `(progn (require :asdf) (funcall (find-symbol @@ -249,7 +253,7 @@ ENTRY-PROGRAM for SYSTEM within the current directory." (declare (ignorable arguments)) ,@entry-program)))))))) -(define (generate-dependency-links lisp registry system) +(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." @@ -265,16 +269,15 @@ to locate its dependent systems." registry))) (define* (make-asd-file asd-file - #:key lisp system version inputs + #: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 - (parameterize ((%lisp (string-append (assoc-ref inputs lisp) "/bin/" lisp))) - (system-dependencies lisp system system-asd-file))) + (system-dependencies system system-asd-file)) (define lisp-input-map - (inputs->asd-file-map inputs lisp)) + (inputs->asd-file-map inputs)) (define registry (filter-map hash-get-handle @@ -291,18 +294,18 @@ system to find its dependencies, as described by GENERATE-DEPENDENCY-LINKS." (display (replace-escaped-macros (format #f "~y~%~y~%" - (generate-system-definition lisp system + (generate-system-definition system #:version version #:dependencies dependencies) - (generate-dependency-links lisp registry system))) + (generate-dependency-links registry system))) port)))) -(define (bundle-asd-file output-path original-asd-file lisp) +(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/.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 lisp)))) + (%bundle-install-prefix)))) (values (string-append bundle-asd-path "/" (basename original-asd-file)) bundle-asd-path))) @@ -317,7 +320,7 @@ which are not nested." (setenv "CL_SOURCE_REGISTRY" (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") "")))) -(define* (build-program lisp program #:key inputs +(define* (build-program program #:key (dependencies (list (basename program))) entry-program #:allow-other-keys) @@ -325,8 +328,7 @@ which are not nested." 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." - (generate-executable lisp program - #:inputs inputs + (generate-executable program #:dependencies dependencies #:entry-program entry-program #:type "program") @@ -337,13 +339,12 @@ has been bound to the command-line arguments which were passed." name))) #t) -(define* (build-image lisp image #:key inputs +(define* (build-image image #:key (dependencies (list (basename image))) #:allow-other-keys) "Generate an image, possibly standalone, which contains all DEPENDENCIES, placing the result in IMAGE.image." - (generate-executable lisp image - #:inputs inputs + (generate-executable image #:dependencies dependencies #:entry-program '(nil) #:type "image") @@ -354,7 +355,7 @@ placing the result in IMAGE.image." (string-append name ".image")))) #t) -(define* (generate-executable lisp out-file #:key inputs +(define* (generate-executable out-file #:key dependencies entry-program type @@ -380,9 +381,7 @@ executable." `(((,bin-directory :**/ :*.*.*) (,bin-directory :**/ :*.*.*))))))) - (parameterize ((%lisp (string-append - (assoc-ref inputs lisp) "/bin/" lisp))) - (generate-executable-for-system type name lisp)) + (generate-executable-for-system type name) (delete-file (string-append bin-directory "/" name "-exec.asd")) (delete-file (string-append bin-directory "/" name "-exec.lisp")))) -- cgit v1.2.3 From 457702b1d9bea593d51e5187b2f104d553fafce4 Mon Sep 17 00:00:00 2001 From: Andy Patterson Date: Sat, 8 Apr 2017 23:48:38 -0400 Subject: 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. --- guix/build-system/asdf.scm | 14 ++++++++++++- guix/build/asdf-build-system.scm | 45 +++++++++++++++++----------------------- guix/build/lisp-utils.scm | 4 ---- 3 files changed, 32 insertions(+), 31 deletions(-) (limited to 'guix/build-system') diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index 4afc6ef1a7..553bbe4825 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -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) @@ -196,7 +199,7 @@ set up using CL source package conventions." (define base-arguments (if target-is-source? (strip-keyword-arguments - '(#:tests? #:asd-file #:lisp) + '(#:tests? #:asd-file #:lisp #:asd-system-name) (package-arguments pkg)) (package-arguments pkg))) @@ -262,6 +265,7 @@ set up using CL source package conventions." #:key source outputs (tests? #t) (asd-file #f) + (asd-system-name #f) (phases '(@ (guix build asdf-build-system) %standard-phases)) (search-paths '()) @@ -270,6 +274,13 @@ 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 "-" prefix. + (define builder `(begin (use-modules ,@modules) @@ -284,6 +295,7 @@ set up using CL source package conventions." ((source) source) (source source)) #:asd-file ,asd-file + #:asd-system-name ,system-name #:system ,system #:tests? ,tests? #:phases ,phases diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index 4305a86af9..20116a4883 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -49,13 +49,6 @@ (define %system-install-prefix (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) (string-append output (%lisp-source-install-prefix) "/" name)) @@ -101,31 +94,32 @@ valid." (define* (install #:key outputs #:allow-other-keys) "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." (let* ((out (library-output outputs)) - (name (remove-lisp-from-name (output-path->package-name out))) (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 (with-directory-excursion install-path (rename-file "source" (string-append (%lisp-type) "-source")) (delete-file-recursively "systems"))) #t) -(define* (build #:key outputs inputs asd-file +(define* (build #:key outputs inputs asd-file asd-system-name #:allow-other-keys) "Compile the system." (let* ((out (library-output outputs)) - (name (remove-lisp-from-name (output-path->package-name out))) - (source-path (lisp-source-directory out name)) + (source-path (lisp-source-directory out asd-system-name)) (translations (wrap-output-translations `(,(output-translation source-path out)))) (asd-file (and=> asd-file - (cut source-asd-file out name <>)))) + (cut source-asd-file out asd-system-name <>)))) (setenv "ASDF_OUTPUT_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 - (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 @@ -146,32 +140,31 @@ valid." (delete-file-recursively cache-directory)))) #t) -(define* (check #:key tests? outputs inputs asd-file +(define* (check #:key tests? outputs inputs asd-file asd-system-name #:allow-other-keys) "Test the system." - (let* ((name (remove-lisp-from-name (outputs->name outputs))) - (out (library-output outputs)) + (let* ((out (library-output outputs)) (asd-file (and=> asd-file - (cut source-asd-file out name <>)))) + (cut source-asd-file out asd-system-name <>)))) (if tests? - (test-system name asd-file) + (test-system asd-system-name asd-file) (format #t "test suite not run~%"))) #t) (define* (create-asd-file #:key outputs inputs asd-file + asd-system-name #:allow-other-keys) "Create a system definition file for the built system." (let*-values (((out) (library-output outputs)) - ((full-name version) (package-name->name+version - (strip-store-file-name out))) - ((name) (remove-lisp-from-name full-name)) + ((_ version) (package-name->name+version + (strip-store-file-name out))) ((new-asd-file) (string-append (library-directory out) - "/" name ".asd"))) + "/" asd-system-name ".asd"))) (make-asd-file new-asd-file - #:system name + #:system asd-system-name #:version version #:inputs inputs #:system-asd-file asd-file)) diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 148357bf0e..2d730570a1 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -36,7 +36,6 @@ generate-executable-for-system %bundle-install-prefix bundle-asd-file - remove-lisp-from-name wrap-output-translations prepend-to-source-registry build-program @@ -66,9 +65,6 @@ (define (%bundle-install-prefix) (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) "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." -- cgit v1.2.3 From 0186a463d0f352eef485326cf57619d23a26734e Mon Sep 17 00:00:00 2001 From: Andy Patterson Date: Mon, 3 Apr 2017 09:01:29 -0400 Subject: build-system/asdf: Always pre-load the system's definition file. * guix/build-system/asdf.scm (asdf-build)[builder]: Pass a default `#:asd-file' argument to the build procedure, using the system's name. * guix/build/asdf-build-system.scm (build, check): Adjust to assume that `asd-file' will always be a string. * guix/build/lisp-utils.scm (compile-system, system-dependencies) (test-system): Likewise. --- guix/build-system/asdf.scm | 2 +- guix/build/asdf-build-system.scm | 11 ++--------- guix/build/lisp-utils.scm | 27 +++++++++------------------ 3 files changed, 12 insertions(+), 28 deletions(-) (limited to 'guix/build-system') diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index 553bbe4825..f842fdcbc3 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -294,7 +294,7 @@ set up using CL source package conventions." (derivation->output-path source)) ((source) source) (source source)) - #:asd-file ,asd-file + #:asd-file ,(or asd-file (string-append system-name ".asd")) #:asd-system-name ,system-name #:system ,system #:tests? ,tests? diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index 20116a4883..4f3fc162ff 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -118,17 +118,11 @@ valid." (translations (wrap-output-translations `(,(output-translation source-path out)))) - (asd-file (and=> asd-file - (cut source-asd-file out asd-system-name <>)))) + (asd-file (source-asd-file out asd-system-name asd-file))) (setenv "ASDF_OUTPUT_TRANSLATIONS" (replace-escaped-macros (format #f "~S" translations))) - ;; We don't need this if we have the asd file, and it can mess with the - ;; load ordering we're trying to enforce - (unless asd-file - (prepend-to-source-registry (string-append source-path "//"))) - (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache (compile-system asd-system-name asd-file) @@ -144,8 +138,7 @@ valid." #:allow-other-keys) "Test the system." (let* ((out (library-output outputs)) - (asd-file (and=> asd-file - (cut source-asd-file out asd-system-name <>)))) + (asd-file (source-asd-file out asd-system-name asd-file))) (if tests? (test-system asd-system-name asd-file) (format #t "test suite not run~%"))) diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 2d730570a1..3f7a6f77c1 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -112,15 +112,12 @@ with PROGRAM." (define (compile-system system asd-file) "Use a lisp implementation to compile SYSTEM using asdf. Load ASD-FILE -first if SYSTEM is defined there." +first." (lisp-eval-program `(progn (require :asdf) - (in-package :asdf) - ,@(if asd-file - `((load ,asd-file)) - '()) - (in-package :cl-user) + (let ((*package* (find-package :asdf))) + (load ,asd-file)) (funcall (find-symbol (symbol-name :operate) (symbol-name :asdf)) @@ -131,15 +128,13 @@ first if SYSTEM is defined there." (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, if necessary." +asdf:system-depends-on. First load the system's ASD-FILE." (define deps-file ".deps.sexp") (define program `(progn (require :asdf) - ,@(if asd-file - `((let ((*package* (find-package :asdf))) - (load ,asd-file))) - '()) + (let ((*package* (find-package :asdf))) + (load ,asd-file)) (with-open-file (stream ,deps-file :direction :output) (format stream @@ -183,16 +178,12 @@ asdf:system-depends-on. First load the system's ASD-FILE, if necessary." '()))) (define (test-system system asd-file) - "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first -if SYSTEM is defined there." + "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first." (lisp-eval-program `(progn (require :asdf) - (in-package :asdf) - ,@(if asd-file - `((load ,asd-file)) - '()) - (in-package :cl-user) + (let ((*package* (find-package :asdf))) + (load ,asd-file)) (funcall (find-symbol (symbol-name :test-system) (symbol-name :asdf)) -- cgit v1.2.3 From 0383afa02ae3777a0adb5304cb6918a2a5f5f250 Mon Sep 17 00:00:00 2001 From: Andy Patterson Date: Sat, 8 Apr 2017 23:43:31 -0400 Subject: build-system/asdf: Handle tests defined in external systems. * 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. --- guix/build-system/asdf.scm | 4 +++- guix/build/asdf-build-system.scm | 8 ++++++-- guix/build/lisp-utils.scm | 18 +++++++++++++++--- 3 files changed, 24 insertions(+), 6 deletions(-) (limited to 'guix/build-system') diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index f842fdcbc3..ec8b64497f 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -199,7 +199,7 @@ set up using CL source package conventions." (define base-arguments (if target-is-source? (strip-keyword-arguments - '(#:tests? #:asd-file #:lisp #:asd-system-name) + '(#:tests? #:asd-file #:lisp #:asd-system-name #:test-asd-file) (package-arguments pkg)) (package-arguments pkg))) @@ -266,6 +266,7 @@ set up using CL source package conventions." (tests? #t) (asd-file #f) (asd-system-name #f) + (test-asd-file #f) (phases '(@ (guix build asdf-build-system) %standard-phases)) (search-paths '()) @@ -296,6 +297,7 @@ set up using CL source package conventions." (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 diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index 1e0a2f6dea..c5e820a00a 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -131,12 +131,16 @@ valid." #t) (define* (check #:key tests? outputs inputs asd-file asd-system-name + test-asd-file #:allow-other-keys) "Test the system." (let* ((out (library-output outputs)) - (asd-file (source-asd-file out asd-system-name asd-file))) + (asd-file (source-asd-file out asd-system-name asd-file)) + (test-asd-file + (and=> test-asd-file + (cut source-asd-file out asd-system-name <>)))) (if tests? - (test-system asd-system-name asd-file) + (test-system asd-system-name asd-file test-asd-file) (format #t "test suite not run~%"))) #t) diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 3b441cf802..21cb620d59 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -184,12 +184,24 @@ asdf:system-depends-on. First load the system's ASD-FILE." `(:lib ,(string-append system ".a")) '()))) -(define (test-system system asd-file) - "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILE first." +(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)) + (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) -- cgit v1.2.3 From d879685176d23c111f4fc665698251b25cdf9124 Mon Sep 17 00:00:00 2001 From: Arun Isaac Date: Wed, 19 Apr 2017 12:59:11 +0530 Subject: build-system: emacs: Install only a subset of files. * guix/build/emacs-build-system.scm (install): Install files matching #:include while excluding files matching #:exclude. * guix/build-system/emacs.scm (emacs-build): Add keyword arguments #:include and #:exclude. --- guix/build-system/emacs.scm | 4 ++++ guix/build/emacs-build-system.scm | 26 +++++++++++++++++++++----- 2 files changed, 25 insertions(+), 5 deletions(-) (limited to 'guix/build-system') diff --git a/guix/build-system/emacs.scm b/guix/build-system/emacs.scm index a7982002b6..9a46ecfd26 100644 --- a/guix/build-system/emacs.scm +++ b/guix/build-system/emacs.scm @@ -83,6 +83,8 @@ (phases '(@ (guix build emacs-build-system) %standard-phases)) (outputs '("out")) + (include ''("^[^/]*\\.el$" "^[^/]*\\.info$" "^doc/.*\\.info$")) + (exclude ''("^\\.dir-locals\\.el$" "-pkg\\.el$" "^[^/]*tests?\\.el$")) (search-paths '()) (system (%current-system)) (guile #f) @@ -108,6 +110,8 @@ #:tests? ,tests? #:phases ,phases #:outputs %outputs + #:include ,include + #:exclude ,exclude #:search-paths ',(map search-path-specification->sexp search-paths) #:inputs %build-inputs))) diff --git a/guix/build/emacs-build-system.scm b/guix/build/emacs-build-system.scm index 3538e9ff47..50af4be363 100644 --- a/guix/build/emacs-build-system.scm +++ b/guix/build/emacs-build-system.scm @@ -95,14 +95,30 @@ store in '.el' files." (substitute-cmd)))) #t)) -(define* (install #:key outputs #:allow-other-keys) +(define* (install #:key outputs + (include '("^[^/]*\\.el$" "^[^/]*\\.info$" "^doc/.*\\.info$")) + (exclude '("^\\.dir-locals\\.el$" "-pkg\\.el$" "^[^/]*tests?\\.el$")) + #:allow-other-keys) "Install the package contents." + + (define source (getcwd)) + + (define (install-file? file stat) + (let ((stripped-file (string-trim (string-drop file (string-length source)) #\/))) + (and (any (cut string-match <> stripped-file) include) + (not (any (cut string-match <> stripped-file) exclude))))) + (let* ((out (assoc-ref outputs "out")) (elpa-name-ver (store-directory->elpa-name-version out)) - (src-dir (getcwd)) - (tgt-dir (string-append out %install-suffix "/" elpa-name-ver))) - (copy-recursively src-dir tgt-dir) - #t)) + (target-directory (string-append out %install-suffix "/" elpa-name-ver))) + (for-each + (lambda (file) + (let* ((stripped-file (string-drop file (string-length source))) + (target-file (string-append target-directory stripped-file))) + (format #t "`~a' -> `~a'~%" file target-file) + (install-file file (dirname target-file)))) + (find-files source install-file?))) + #t) (define* (move-doc #:key outputs #:allow-other-keys) "Move info files from the ELPA package directory to the info directory." -- cgit v1.2.3