From mboxrd@z Thu Jan 1 00:00:00 1970 From: Andy Patterson Subject: [PATCH v2 01/13] build-system: Add asdf-build-system. Date: Sun, 2 Oct 2016 22:41:27 -0400 Message-ID: <20161003024139.19975-2-ajpatter@uwaterloo.ca> References: <20160927041532.27097-1-ajpatter@uwaterloo.ca> <20161003024139.19975-1-ajpatter@uwaterloo.ca> Mime-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: quoted-printable Return-path: Received: from eggs.gnu.org ([2001:4830:134:3::10]:45373) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bqtCV-0008E2-Ta for guix-devel@gnu.org; Sun, 02 Oct 2016 22:42:01 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1bqtCQ-0004ru-IZ for guix-devel@gnu.org; Sun, 02 Oct 2016 22:41:54 -0400 Received: from mailservices.uwaterloo.ca ([129.97.128.141]:45333 helo=minos.uwaterloo.ca) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1bqtCQ-0004rm-8O for guix-devel@gnu.org; Sun, 02 Oct 2016 22:41:50 -0400 In-Reply-To: <20161003024139.19975-1-ajpatter@uwaterloo.ca> List-Id: "Development of GNU Guix and the GNU System distribution." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-devel-bounces+gcggd-guix-devel=m.gmane.org@gnu.org Sender: "Guix-devel" To: guix-devel@gnu.org * guix/build-system/asdf.scm: New file. * guix/build/asdf-build-system.scm: New file. * guix/build/lisp-utils.scm: New file. * Makefile.am: Add them. * doc/guix.texi: Add section on 'asdf-build-system/source'. --- Makefile.am | 3 + doc/guix.texi | 60 ++++++ guix/build-system/asdf.scm | 385 +++++++++++++++++++++++++++++++++= ++++ guix/build/asdf-build-system.scm | 400 +++++++++++++++++++++++++++++++++= ++++++ guix/build/lisp-utils.scm | 240 +++++++++++++++++++++++ 5 files changed, 1088 insertions(+) create mode 100644 guix/build-system/asdf.scm create mode 100644 guix/build/asdf-build-system.scm create mode 100644 guix/build/lisp-utils.scm diff --git a/Makefile.am b/Makefile.am index 43a33c8..a23e5fd 100644 --- a/Makefile.am +++ b/Makefile.am @@ -63,6 +63,7 @@ MODULES =3D \ guix/build-system/ant.scm \ guix/build-system/cmake.scm \ guix/build-system/emacs.scm \ + guix/build-system/asdf.scm \ guix/build-system/glib-or-gtk.scm \ guix/build-system/gnu.scm \ guix/build-system/haskell.scm \ @@ -84,6 +85,7 @@ MODULES =3D \ guix/build/download.scm \ guix/build/cmake-build-system.scm \ guix/build/emacs-build-system.scm \ + guix/build/asdf-build-system.scm \ guix/build/git.scm \ guix/build/hg.scm \ guix/build/glib-or-gtk-build-system.scm \ @@ -106,6 +108,7 @@ MODULES =3D \ guix/build/syscalls.scm \ guix/build/gremlin.scm \ guix/build/emacs-utils.scm \ + guix/build/lisp-utils.scm \ guix/build/graft.scm \ guix/build/bournish.scm \ guix/build/qt-utils.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index f5bbb92..53db367 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2965,6 +2965,66 @@ that should be run during the @code{build} phase. = By default the =20 @end defvr =20 +@defvr {Scheme Variable} asdf-build-system/source +@defvrx {Scheme Variable} asdf-build-system/sbcl +@defvrx {Scheme Variable} asdf-build-system/ecl + +These variables, exported by @code{(guix build-system sbcl)}, implement +build procedures for Common Lisp packages using the +@url{https://common-lisp.net/project/asdf/, ``ASDF''} system. + +The @code{asdf-build-system/source} system installs the packages in +source form, and can be loaded using any common lisp implementation, via +ASDF. The others, such as @code{asdf-build-system/sbcl}, install binary +systems in the format which a particular implementation understands. +These build systems can also be used to produce executable programs, or +lisp images which contain a set of packages pre-loaded. + +The build system uses conventions to determine the roles of inputs in +the build system. For binary packages, the package itself as well as +its dependencies should begin their name with the lisp implementation, +such as @code{sbcl-} for @code{asdf-build-system/sbcl}. If dependencies +are used only for tests, it is convenient to use a different prefix in +order to avoid having a run-time dependency on such systems. For +example, + +@example +(define-public sbcl-bordeaux-threads + (package + ... + (native-inputs `(("tests:cl-fiveam" ,sbcl-fiveam))) + ...)) +@end example + +Additionally, the corresponding source package should be labelled using +the same convention as python packages (see @ref{Python Modules}), using +the @code{cl-} prefix. + +One package should be defined for each ASDF system. + +The package outputs control whether or not executable programs and +images are built alongside the package's usual output, using the +@code{bin} and @code{image} outputs, respectively. + +Packages can also be built which combine other packages into an +executable program or image only, without building another system. +Specifying one of the @code{#:binary?} or @code{#:image?} parameters +will produce this behaviour. + +When building an executable program, the @code{#:entry-program} +parameter, which should be a list of Common Lisp expressions, must be +used to specify what program should be run. In this program, +@code{arguments} will be bound to the command-line arguments passed. + +The @code{#:image-dependencies} parameter can be used to add packages to +the pre-loaded systems included in the executable program or image. +@code{#:compile-dependencies} specifies a list of additional systems +which should be loaded before a system is compiled. If the package +depends on special systems exported by the implementation itself, the +@code{#:special-dependencies} parameter should be used to specify them. + +@end defvr + @defvr {Scheme Variable} cmake-build-system This variable is exported by @code{(guix build-system cmake)}. It implements the build procedure for packages using the diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm new file mode 100644 index 0000000..eb8b7d9 --- /dev/null +++ b/guix/build-system/asdf.scm @@ -0,0 +1,385 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2016 Andy Patterson +;;; +;;; 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 (a= t +;;; 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-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 a= n +;; 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-specificatio= n->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-SY= STEM, +and returns one using TO-BUILD-SYSTEM. If PKG was prefixed by FROM-PREFI= X, the +resulting package will be prefixed by TO-PREFIX. Inputs of PKG are recur= sively +transformed using the same rule. The result's #:phases argument will be +modified by PHASES-TRANSFORMER, a list 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 transform= ation +would otherwise produce. + +If TO-BUILD-SYSTEM is asdf-build-system/source, the resulting package wi= ll be +set up using CL source package conventions." + (define target-is-source? (eq? 'asdf/source + (build-system-name 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? (build-system-name from-build-system) + (build-system-name (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) cont= ent)) + (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 input= s 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 #:entry-program + #:image-dependencies #:compile-dependencies #:image? + #:binary? #:test-only-systems #:lisp) + (package-arguments pkg)) + (package-arguments pkg))) + + (cond + ((and variant-property + (assoc-ref (package-properties pkg) variant-property)) + =3D> 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 argument= s)))))) + +(define (asdf-build lisp-implementation) + (lambda* (store name inputs + #:key source outputs + (tests? #t) + (special-dependencies ''()) + (entry-program #f) + (image-dependencies ''()) + (compile-dependencies ''()) + (image? #f) + (binary? #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 + #:entry-program ,entry-program + #:image-dependencies ,image-dependencies + #:compile-dependencies ,compile-dependencies + #:image? ,image? + #:binary? ,binary? + #:test-only-systems ,test-only-systems + #:system ,system + #:tests? ,tests? + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->se= xp + 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 source-package->sbcl-package + (let* ((property 'sbcl-variant) + (transformer + (package-with-build-system asdf-build-system/source + asdf-build-system/sbcl + "cl-" + "sbcl-" + #:variant-property property + #:phases-transformer + 'source-phases->sbcl-phases))) + (lambda (pkg) + (transformer + (strip-variant-as-necessary property pkg))))) + +(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 diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-sys= tem.scm new file mode 100644 index 0000000..7554b54 --- /dev/null +++ b/guix/build/asdf-build-system.scm @@ -0,0 +1,400 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2016 Andy Patterson +;;; +;;; 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 (a= t +;;; 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 asdf-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build utils) + #:use-module (guix build lisp-utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 receive) + #:use-module (ice-9 regex) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:export (%standard-phases + %standard-phases/source + asdf-build + asdf-build/source)) + +;; Commentary: +;; +;; System for building ASDF packages; creating executable programs and i= mages +;; from them. +;; +;; Code: + +(define %object-prefix "/lib") + +(define (source-install-prefix lisp) + (string-append %install-prefix "/" lisp "-source")) + +(define %system-install-prefix + (string-append %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 (wrap-source-registry registry) + `(:source-registry + ,@registry + :inherit-configuration)) + +(define (wrap-output-translations translations) + `(:output-translations + ,@translations + :inherit-configuration)) + +(define (lisp-source-directory output lisp name) + (string-append output (source-install-prefix lisp) "/" name)) + +(define (source-directory output name) + (string-append output %install-prefix "/source/" name)) + +(define (library-directory output lisp) + (string-append output %object-prefix + "/" lisp)) + +(define (output-translation source-path + object-output + lisp) + "Return a translation for the system's source path +to it's binary output." + `((,source-path + :**/ :*.*.*) + (,(library-directory object-output lisp) + :**/ :*.*.*))) + +(define (source-registry source-path) + `(:tree ,source-path)) + +(define (lisp-dependency-names lisp inputs) + (map first (lisp-dependencies lisp inputs))) + +(define (copy-files-to-output outputs output name) + "Copy all files from OUTPUT to \"out\". Create an extra link to any +system-defining files in the source to a convenient location. This is do= ne +before any compiling so that the compiled source locations will be valid= ." + (let* ((out (assoc-ref outputs output)) + (source (getcwd)) + (target (source-directory out name)) + (system-path (string-append out %system-install-prefix))) + (copy-recursively source target) + (mkdir-p system-path) + (for-each + (lambda (file) + (symlink file + (string-append system-path "/" (basename file)))) + (find-files target "\\.asd$")) + #t)) + +(define* (install #:key outputs #:allow-other-keys) + "Copy and symlink all the source files." + (copy-files-to-output outputs "out" (outputs->name outputs))) + +(define* (copy-source #:key outputs lisp + image? binary? + #:allow-other-keys) + "Copy the source to \"out\"." + (unless (or binary? image?) + (let* ((out (assoc-ref outputs "out")) + (name (remove-lisp-from-name (output-path->package-name out) = lisp)) + (install-path (string-append out %install-prefix))) + (copy-files-to-output outputs "out" name) + ;; Hide the files from asdf + (with-directory-excursion install-path + (rename-file "source" (string-append lisp "-source")) + (delete-file-recursively "systems")))) + #t) + +(define* (build #:key outputs inputs lisp + compile-dependencies + image? + binary? + #:allow-other-keys) + "Compile the system." + + (unless (or binary? image?) + (let* ((out (assoc-ref outputs "out")) + (name (remove-lisp-from-name (output-path->package-name out) = lisp)) + (source-path (lisp-source-directory out lisp name)) + (translations (wrap-output-translations + `(,(output-translation source-path + out + lisp))))) + + (setenv "ASDF_OUTPUT_TRANSLATIONS" + (replace-escaped-macros (format #f "~S" translations))) + (setenv "CL_SOURCE_REGISTRY" + (replace-escaped-macros + (format #f "~S" (wrap-source-registry + `(,(source-registry source-path)))))) + + (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 compile-dependencies)) + + ;; As above, ecl will sometimes create this even though it doesn't= use it + + (let ((cache-directory (string-append out "/.cache"))) + (when (directory-exists? cache-directory) + (delete-file-recursively cache-directory))))) + #t) + +(define* (check #:key lisp tests? outputs inputs + compile-dependencies + image? + binary? + #:allow-other-keys) + "Test the system." + + (if (and tests? (not image?) (not binary?)) + (parameterize ((%lisp (string-append + (assoc-ref inputs lisp) "/bin/" lisp))) + (test-system + (remove-lisp-from-name (outputs->name outputs) lisp) + lisp + compile-dependencies)) + (format #t "test suite not run~%")) + #t) + +(define* (patch-asd-files #:key outputs + inputs + lisp + special-dependencies + image? + binary? + test-only-systems + #: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 on= ly +included to run tests. Add any SPECIAL-DEPENDENCIES which the LISP +implementation itself provides." + (unless (or image? binary?) + (let* ((out (assoc-ref outputs "out")) + (name (remove-lisp-from-name (output-path->package-name out) = lisp)) + (registry (lset-difference + (lambda (input system) + (match input + ((name . path) (string=3D? 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$")))) + #t) + +(define* (symlink-asd-files #:key outputs lisp + image? binary? + #:allow-other-keys) + "Create an extra reference to the system in a convenient location." + (unless (or image? binary?) + (let* ((out (assoc-ref outputs "out"))) + (for-each + (lambda (asd-file) + (receive (new-asd-file asd-file-directory) + (bundle-asd-file out asd-file lisp) + (mkdir-p asd-file-directory) + (symlink asd-file new-asd-file))) + + (find-files (string-append out %object-prefix) "\\.asd$")))) + #t) + +(define* (generate-binary #:key outputs + inputs + image-dependencies + entry-program + lisp + binary? + #:allow-other-keys) + "Generate a binary program for the system, either in \"bin\" if the pa= ckage +also contains a library system, or in \"out\" otherwise." + (define output (if binary? "out" "bin")) + (generate-executable #:outputs outputs + #:inputs inputs + #:image-dependencies image-dependencies + #:entry-program entry-program + #:lisp lisp + #:output output + #:needs-own-system? (not binary?) + #:type "program") + (and=3D> + (assoc-ref outputs output) + (lambda (bin) + (let* ((full-name (outputs->name outputs)) + (name (if binary? full-name + (remove-lisp-from-name full-name lisp))) + (bin-directory (string-append bin "/bin"))) + (with-directory-excursion bin-directory + (rename-file (string-append name "-exec") + name))))) + #t) + +(define* (generate-image #:key outputs + inputs + image-dependencies + lisp + image? + #:allow-other-keys) + "Generate an image for the system, possibly standalone, either in \"im= age\" +if the package also contains a library system, or in \"out\" otherwise." + (define output (if image? "out" "image")) + (generate-executable #:outputs outputs + #:inputs inputs + #:image-dependencies image-dependencies + #:entry-program '(nil) + #:lisp lisp + #:output output + #:needs-own-system? (not image?) + #:type "image") + (and=3D> + (assoc-ref outputs output) + (lambda (image) + (let* ((full-name (outputs->name outputs)) + (name (if image? full-name + (remove-lisp-from-name full-name lisp))) + (bin-directory (string-append image "/bin"))) + (with-directory-excursion bin-directory + (rename-file (string-append name "-exec--all-systems.image") + (string-append name ".image")))))) + #t) + +(define* (generate-executable #:key outputs + image-dependencies + entry-program + lisp + output + inputs + type + needs-own-system? + #:allow-other-keys) + "Generate an executable by using asdf's TYPE-op, containing whithin th= e +image all IMAGE-DEPNDENCIES, and running ENTRY-PROGRAM in the case of an +executable." + (and=3D> + (assoc-ref outputs output) + (lambda (out) + (let* ((bin-directory (string-append out "/bin")) + (full-name (outputs->name outputs)) + (name (if needs-own-system? + (remove-lisp-from-name full-name lisp) + full-name))) + (mkdir-p out) + (with-directory-excursion out + (generate-executable-wrapper-system name + image-dependencies + needs-own-system?) + (generate-executable-entry-point name entry-program)) + + (setenv "CL_SOURCE_REGISTRY" + (replace-escaped-macros + (format + #f "~S" + (wrap-source-registry + `(,(source-registry (assoc-ref outputs "out")) + ,(source-registry out)))))) + + (setenv "ASDF_OUTPUT_TRANSLATIONS" + (replace-escaped-macros + (format + #f "~S" + (wrap-output-translations + `(((,out :**/ :*.*.*) + (,bin-directory :**/ :*.*.*))))))) + + (parameterize ((%lisp (string-append + (assoc-ref inputs lisp) "/bin/" lisp))) + (generate-executable-for-system type name lisp)) + + (delete-file (string-append out "/" name "-exec.asd")) + (delete-file (string-append out "/" name "-exec.lisp")))))) + +(define* (cleanup-files #:key outputs binary? image? lisp + #:allow-other-keys) + "Remove any compiled files which are not a part of the final bundle." + (unless (or binary? image?) + (let ((out (assoc-ref outputs "out"))) + (match lisp + ("sbcl" + (for-each + (lambda (file) + (unless (string-suffix? "--system.fasl" file) + (delete-file file))) + (find-files out "\\.fasl$"))) + ("ecl" + (for-each delete-file + (append (find-files out "\\.fas$") + (find-files out "\\.o$"))))))) + #t) + +(define* (strip #:key lisp #:allow-other-keys #:rest args) + ;; stripping sbcl binaries removes their entry program and extra syste= ms + (unless (string=3D? lisp "sbcl") + (apply (assoc-ref gnu:%standard-phases 'strip) args)) + #t) + +(define %standard-phases/source + (modify-phases gnu:%standard-phases + (delete 'configure) + (delete 'check) + (delete 'build) + (replace 'install install))) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (delete 'configure) + (delete 'install) + (replace 'build build) + (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 'create-symlinks symlink-asd-files) + (add-after 'create-symlinks 'cleanup cleanup-files) + (add-after 'cleanup 'generate-binary generate-binary) + (add-after 'generate-binary 'generate-image generate-image))) + +(define* (asdf-build #:key inputs + (phases %standard-phases) + #:allow-other-keys + #:rest args) + (apply gnu:gnu-build + #:inputs inputs + #:phases phases + args)) + +(define* (asdf-build/source #:key inputs + (phases %standard-phases/source) + #:allow-other-keys + #:rest args) + (apply gnu:gnu-build + #:inputs inputs + #:phases phases + args)) + +;;; asdf-build-system.scm ends here diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm new file mode 100644 index 0000000..f67e38b --- /dev/null +++ b/guix/build/lisp-utils.scm @@ -0,0 +1,240 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright =C2=A9 2016 Andy Patterson +;;; +;;; 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 (a= t +;;; 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 lisp-utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%lisp + %install-prefix + lisp-eval-program + compile-system + test-system + replace-escaped-macros + 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)) + +;;; Commentary: +;;; +;;; Tools to evaluate lisp programs within a lisp session, generate wrap= per +;;; systems for executables. Compile, test, and produce images for syste= ms and +;;; programs, and link them with their dependencies. +;;; +;;; Code: + +(define %lisp + (make-parameter "lisp")) + +(define %install-prefix "/share/common-lisp") + +(define (bundle-install-prefix lisp) + (string-append %install-prefix "/" lisp "-bundle-systems")) + +(define (remove-lisp-from-name name lisp) + (string-drop name (1+ (string-length lisp)))) + +(define (lisp-eval-program lisp 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))) + +(define (lisp-invoke lisp program) + "Return a list of arguments for system* determining how to invoke LISP +with PROGRAM." + (match lisp + ("sbcl" `(,(%lisp) "--non-interactive" "--eval" ,program)) + ("ecl" `(,(%lisp) "-eval" ,program "-eval" "(quit)")))) + +(define (asdf-load-all systems) + (map (lambda (system) + `(funcall + (find-symbol + (symbol-name :load-system) + (symbol-name :asdf)) + ,system)) + systems)) + +(define (compile-system system lisp other-required-systems) + "Use a lisp implementation to compile SYSTEM using asdf. Loads +OTHER-REQUIRED-SYSTEMS before beginning compilation." + (lisp-eval-program lisp + `(progn + (require :asdf) + ,@(asdf-load-all other-required-systems) + (funcall (find-symbol + (symbol-name :operate) + (symbol-name :asdf)) + (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 (test-system system lisp other-required-systems) + "Use a lisp implementation to test SYSTEM using asdf. Loads +OTHER-REQUIRED-SYSTEMS before beginning to test." + (lisp-eval-program lisp + `(progn + (require :asdf) + ,@(asdf-load-all other-required-systems) + (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) + "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 + (symbol-name :operate) + (symbol-name :asdf)) + (find-symbol + (symbol-name ,(string->lisp-keyword type "-op")) + (symbol-name :asdf)) + ,(string-append system "-exec"))))) + +(define (generate-executable-wrapper-system system + dependencies + needs-system?) + "Generates a system which can be used by asdf to produce an image or p= rogram +inside the current directory. The image or program will contain SYSTEM a= nd all +other DEPENDENCIES, which may not be depended on by the SYSTEM itself. S= YSTEM +will be excluded unless NEEDS-SYSTEM? is #t." + (with-output-to-file (string-append system "-exec.asd") + (lambda _ + (format #t "~y~%" + `(defsystem ,(string->lisp-keyword system "-exec") + :entry-point ,(string-append system "-exec:main") + :depends-on (:uiop + ,@(if needs-system? + `(,(string->lisp-keyword system)) + '()) + ,@(map string->lisp-keyword + dependencies)) + :components ((:file ,(string-append system "-exec")))))= ))) + +(define (generate-executable-entry-point system entry-program) + "Generates an entry point program from the list of lisp statements +ENTRY-PROGRAM for SYSTEM within the current directory." + (with-output-to-file (string-append system "-exec.lisp") + (lambda _ + (let ((system (string->lisp-keyword system "-exec"))) + (format #t "~{~y~%~%~}" + `((defpackage ,system + (:use :cl) + (:export :main)) + + (in-package ,system) + + (defun main () + (let ((arguments uiop:*command-line-arguments*)) + (declare (ignorable arguments)) + ,@entry-program)))))))) + +(define (wrap-perform-method lisp registry dependencies file-name) + "Creates a wrapper method which allows the system to locate its depend= ent +systems from REGISTRY, an alist of the same form as %outputs, which cont= ains +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 l= isp) + "/" 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-M= ETHOD." + (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 con= vention +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 (bundle-asd-file output-path original-asd-file lisp) + "Find the symlinked bundle file for ORIGINAL-ASD-FILE by looking +in OUTPUT-PATH/lib/LISP/.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)))) + (values (string-append bundle-asd-path "/" (basename original-asd-fi= le)) + bundle-asd-path))) + +(define (replace-escaped-macros string) + "Replace simple lisp forms that the guile writer escapes, for +example by replacing #{#p}# with #p. Should only be used to replace +truly simple forms which are not nested." + (regexp-substitute/global #f "(#\\{)(\\S*)(\\}#)" string + 'pre 2 'post)) --=20 2.10.0