diff --git a/Makefile.am b/Makefile.am index 1690a94de4..7f2281cfa4 100644 --- a/Makefile.am +++ b/Makefile.am @@ -63,6 +63,7 @@ MODULES = \ 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 = \ 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 = \ 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 7d7ebbee75..57821c5617 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -2967,6 +2967,63 @@ that should be run during the @code{build} phase. By default the @end defvr +@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 asdf)}, implement +build procedures for Common Lisp packages using +@url{https://common-lisp.net/project/asdf/, ``ASDF''}. ASDF is a system +definition facility for Common Lisp programs and libraries. + +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 naming conventions. For binary packages, the +package itself as well as its run-time dependencies should begin their +name with the lisp implementation, such as @code{sbcl-} for +@code{asdf-build-system/sbcl}. Beginning the input name with this +prefix will allow the build system to encode its location into the +resulting library, so that the input can be found at run-time. + +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 labeled using +the same convention as python packages (see @ref{Python Modules}), using +the @code{cl-} prefix. + +For binary packages, each system should be defined as a Guix package. +If one package @code{origin} contains several systems, package variants +can be created in order to build all the systems. Source packages, +which use @code{asdf-build-system/source}, may contain several systems. + +In order to create executable programs and images, the build-side +procedures @code{build-program} and @code{build-image} can be used. +They should be called in a build phase after the @code{create-symlinks} +phase, so that the system which was just built can be used within the +resulting image. @code{build-program} requires a list of Common Lisp +expressions to be passed as the @code{#:entry-program} argument. + +If the system is not defined within its own @code{.asd} file of the same +name, then the @code{#:asd-file} parameter should be used to specify +which file the system is defined in. + +@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 0000000000..f28c098ea2 --- /dev/null +++ b/guix/build-system/asdf.scm @@ -0,0 +1,360 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2016 Andy Patterson +;;; +;;; 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-system asdf) + #:use-module (guix store) + #:use-module (guix utils) + #:use-module (guix packages) + #:use-module (guix derivations) + #:use-module (guix search-paths) + #:use-module (guix build-system) + #:use-module (guix build-system gnu) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%asdf-build-system-modules + %asdf-build-modules + asdf-build + asdf-build-system/sbcl + asdf-build-system/ecl + asdf-build-system/source + sbcl-package->cl-source-package + sbcl-package->ecl-package)) + +;; Commentary: +;; +;; Standard build procedure for asdf packages. This is implemented as an +;; extension of 'gnu-build-system'. +;; +;; Code: + +(define %asdf-build-system-modules + ;; Imported build-side modules + `((guix build asdf-build-system) + (guix build lisp-utils) + ,@%gnu-build-system-modules)) + +(define %asdf-build-modules + ;; Used (visible) build-side modules + '((guix build asdf-build-system) + (guix build utils) + (guix build lisp-utils))) + +(define (default-lisp implementation) + "Return the default package for the lisp IMPLEMENTATION." + ;; Lazily resolve the binding to avoid a circular dependancy. + (let ((lisp-module (resolve-interface '(gnu packages lisp)))) + (module-ref lisp-module implementation))) + +(define* (lower/source name + #:key source inputs outputs native-inputs system target + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME" + (define private-keywords + '(#:target #:inputs #:native-inputs)) + + (and (not target) + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ,@(standard-packages))) + (build-inputs native-inputs) + (outputs outputs) + (build asdf-build/source) + (arguments (strip-keyword-arguments private-keywords arguments))))) + +(define* (asdf-build/source store name inputs + #:key source outputs + (phases '(@ (guix build asdf-build-system) + %standard-phases/source)) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %asdf-build-system-modules) + (modules %asdf-build-modules)) + (define builder + `(begin + (use-modules ,@modules) + (asdf-build/source #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) source) + (source source)) + #:system ,system + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build)) + +(define* (package-with-build-system from-build-system to-build-system + from-prefix to-prefix + #:key variant-property + phases-transformer) + "Return a precedure which takes a package PKG which uses FROM-BUILD-SYSTEM, +and returns one using TO-BUILD-SYSTEM. If PKG was prefixed by FROM-PREFIX, +the resulting package will be prefixed by TO-PREFIX. Inputs of PKG are +recursively transformed using the same rule. The result's #:phases argument +will be modified by PHASES-TRANSFORMER, an S-expression which evaluates on the +build side to a procedure of one argument. + +VARIANT-PROPERTY can be added to a package's properties to indicate that the +corresponding package promise should be used as the result of this +transformation. This allows the result to differ from what the transformation +would otherwise produce. + +If TO-BUILD-SYSTEM is asdf-build-system/source, the resulting package will be +set up using CL source package conventions." + (define target-is-source? (eq? asdf-build-system/source to-build-system)) + + (define (transform-package-name name) + (if (string-prefix? from-prefix name) + (let ((new-name (string-drop name (string-length from-prefix)))) + (if (string-prefix? to-prefix new-name) + new-name + (string-append to-prefix new-name))) + name)) + + (define (has-from-build-system? pkg) + (eq? from-build-system (package-build-system pkg))) + + (define transform + (memoize + (lambda (pkg) + (define rewrite + (match-lambda + ((name content . rest) + (let* ((is-package? (package? content)) + (new-content (if is-package? (transform content) content)) + (new-name (if (and is-package? + (string-prefix? from-prefix name)) + (package-name new-content) + name))) + `(,new-name ,new-content ,@rest))))) + + ;; Special considerations for source packages: CL inputs become + ;; propagated, and un-handled arguments are removed. Native inputs are + ;; removed as are extraneous outputs. + (define new-propagated-inputs + (if target-is-source? + (map rewrite + (filter (match-lambda + ((_ input . _) + (has-from-build-system? input))) + (package-inputs pkg))) + '())) + + (define new-inputs + (if target-is-source? + (map rewrite + (filter (match-lambda + ((_ input . _) + (not (has-from-build-system? input)))) + (package-inputs pkg))) + (map rewrite (package-inputs pkg)))) + + (define base-arguments + (if target-is-source? + (strip-keyword-arguments + '(#:tests? #:special-dependencies #:asd-file + #:test-only-systems #:lisp) + (package-arguments pkg)) + (package-arguments pkg))) + + (cond + ((and variant-property + (assoc-ref (package-properties pkg) variant-property)) + => force) + + ((has-from-build-system? pkg) + (package + (inherit pkg) + (location (package-location pkg)) + (name (transform-package-name (package-name pkg))) + (build-system to-build-system) + (arguments + (substitute-keyword-arguments base-arguments + ((#:phases phases) (list phases-transformer phases)))) + (inputs new-inputs) + (propagated-inputs new-propagated-inputs) + (native-inputs (if target-is-source? + '() + (map rewrite (package-native-inputs pkg)))) + (outputs (if target-is-source? + '("out") + (package-outputs pkg))))) + (else pkg))))) + + transform) + +(define (strip-variant-as-necessary variant pkg) + (define properties (package-properties pkg)) + (if (assoc variant properties) + (package + (inherit pkg) + (properties (alist-delete variant properties))) + pkg)) + +(define (lower lisp-implementation) + (lambda* (name + #:key source inputs outputs native-inputs system target + (lisp (default-lisp (string->symbol lisp-implementation))) + #:allow-other-keys + #:rest arguments) + "Return a bag for NAME" + (define private-keywords + '(#:target #:inputs #:native-inputs #:lisp)) + + (and (not target) + (bag + (name name) + (system system) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ,@(standard-packages))) + (build-inputs `((,lisp-implementation ,lisp) + ,@native-inputs)) + (outputs outputs) + (build (asdf-build lisp-implementation)) + (arguments (strip-keyword-arguments private-keywords arguments)))))) + +(define (asdf-build lisp-implementation) + (lambda* (store name inputs + #:key source outputs + (tests? #t) + (special-dependencies ''()) + (asd-file #f) + (test-only-systems ''()) + (lisp lisp-implementation) + (phases '(@ (guix build asdf-build-system) + %standard-phases)) + (search-paths '()) + (system (%current-system)) + (guile #f) + (imported-modules %asdf-build-system-modules) + (modules %asdf-build-modules)) + + (define builder + `(begin + (use-modules ,@modules) + (asdf-build #:name ,name + #:source ,(match (assoc-ref inputs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) source) + (source source)) + #:lisp ,lisp + #:special-dependencies ,special-dependencies + #:asd-file ,asd-file + #:test-only-systems ,test-only-systems + #:system ,system + #:tests? ,tests? + #:phases ,phases + #:outputs %outputs + #:search-paths ',(map search-path-specification->sexp + search-paths) + #:inputs %build-inputs))) + + (define guile-for-build + (match guile + ((? package?) + (package-derivation store guile system #:graft? #f)) + (#f + (let* ((distro (resolve-interface '(gnu packages commencement))) + (guile (module-ref distro 'guile-final))) + (package-derivation store guile system #:graft? #f))))) + + (build-expression->derivation store name builder + #:inputs inputs + #:system system + #:modules imported-modules + #:outputs outputs + #:guile-for-build guile-for-build))) + +(define asdf-build-system/sbcl + (build-system + (name 'asdf/sbcl) + (description "The build system for ASDF binary packages using SBCL") + (lower (lower "sbcl")))) + +(define asdf-build-system/ecl + (build-system + (name 'asdf/ecl) + (description "The build system for ASDF binary packages using ECL") + (lower (lower "ecl")))) + +(define asdf-build-system/source + (build-system + (name 'asdf/source) + (description "The build system for ASDF source packages") + (lower lower/source))) + +(define sbcl-package->cl-source-package + (let* ((property 'cl-source-variant) + (transformer + (package-with-build-system asdf-build-system/sbcl + asdf-build-system/source + "sbcl-" + "cl-" + #:variant-property property + #:phases-transformer + '(const %standard-phases/source)))) + (lambda (pkg) + (transformer + (strip-variant-as-necessary property pkg))))) + +(define sbcl-package->ecl-package + (let* ((property 'ecl-variant) + (transformer + (package-with-build-system asdf-build-system/sbcl + asdf-build-system/ecl + "sbcl-" + "ecl-" + #:variant-property property + #:phases-transformer + 'identity))) + (lambda (pkg) + (transformer + (strip-variant-as-necessary property pkg))))) + +;;; asdf.scm ends here diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm new file mode 100644 index 0000000000..085d073dea --- /dev/null +++ b/guix/build/asdf-build-system.scm @@ -0,0 +1,282 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 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 (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 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) + #:use-module (ice-9 ftw) + #:export (%standard-phases + %standard-phases/source + asdf-build + asdf-build/source)) + +;; Commentary: +;; +;; System for building ASDF packages; creating executable programs and images +;; 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 (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-asd-file output lisp name asd-file) + (string-append (lisp-source-directory output lisp name) "/" asd-file)) + +(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 done +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 #:allow-other-keys) + "Copy the source to \"out\"." + (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 asd-file + #:allow-other-keys) + "Compile the system." + (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)))) + (asd-file (and=> asd-file (cut source-asd-file out lisp name <>)))) + + (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 + + (parameterize ((%lisp (string-append + (assoc-ref inputs lisp) "/bin/" lisp))) + (compile-system name lisp asd-file)) + + ;; 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 asd-file + #:allow-other-keys) + "Test the system." + (let* ((name (remove-lisp-from-name (outputs->name outputs) lisp)) + (out (assoc-ref outputs "out")) + (asd-file (and=> asd-file (cut source-asd-file out lisp name <>)))) + (if tests? + (parameterize ((%lisp (string-append + (assoc-ref inputs lisp) "/bin/" lisp))) + (test-system name lisp asd-file)) + (format #t "test suite not run~%"))) + #t) + +(define* (patch-asd-files #:key outputs + inputs + lisp + special-dependencies + 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 only +included to run tests. Add any SPECIAL-DEPENDENCIES which the LISP +implementation itself provides." + (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=? 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 #:allow-other-keys) + "Create an extra reference to the system in a convenient location." + (let* ((out (assoc-ref outputs "out"))) + (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) + (symlink asd-file new-asd-file) + ;; Update the source registry for future phases which might want to + ;; use the newly compiled system. + (prepend-to-source-registry + (string-append asd-file-directory "/")))) + + (find-files (string-append out %object-prefix) "\\.asd$")) +) + #t) + +(define* (cleanup-files #:key outputs lisp + #:allow-other-keys) + "Remove any compiled files which are not a part of the final bundle." + (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$") + (find-files out "\\.a$"))))) + + (with-directory-excursion (library-directory out lisp) + (for-each + (lambda (file) + (rename-file file + (string-append "./" (basename file)))) + (find-files ".")) + (for-each delete-file-recursively + (scandir "." + (lambda (file) + (and + (directory-exists? file) + (string<> "." file) + (string<> ".." file))))))) + #t) + +(define* (strip #:key lisp #:allow-other-keys #:rest args) + ;; stripping sbcl binaries removes their entry program and extra systems + (or (string=? lisp "sbcl") + (apply (assoc-ref gnu:%standard-phases 'strip) args))) + +(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 'cleanup cleanup-files) + (add-after 'cleanup 'create-symlinks symlink-asd-files))) + +(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 0000000000..55a07c7207 --- /dev/null +++ b/guix/build/lisp-utils.scm @@ -0,0 +1,327 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 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 (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 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) + #:use-module (guix build utils) + #: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 + wrap-output-translations + prepend-to-source-registry + build-program + build-image)) + +;;; Commentary: +;;; +;;; Tools to evaluate lisp programs within a lisp session, generate wrapper +;;; systems for executables. Compile, test, and produce images for systems and +;;; programs, and link them with their dependencies. +;;; +;;; Code: + +(define %lisp + ;; File name of the Lisp compiler. + (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 (wrap-output-translations translations) + `(:output-translations + ,@translations + :inherit-configuration)) + +(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 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) + (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 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)))) + +(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) + "Generates a system which can be used by asdf to produce an image or program +inside the current directory. The image or program will contain +DEPENDENCIES." + (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 + ,@(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 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 (bundle-asd-file output-path original-asd-file lisp) + "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)))) + (values (string-append bundle-asd-path "/" (basename original-asd-file)) + 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)) + +(define (prepend-to-source-registry path) + (setenv "CL_SOURCE_REGISTRY" + (string-append path ":" (or (getenv "CL_SOURCE_REGISTRY") "")))) + +(define* (build-program lisp program #:key inputs + (dependencies (list (basename program))) + entry-program + #:allow-other-keys) + "Generate an executable program containing all DEPENDENCIES, and which will +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 + #:dependencies dependencies + #:entry-program entry-program + #:type "program") + (let* ((name (basename program)) + (bin-directory (dirname program))) + (with-directory-excursion bin-directory + (rename-file (string-append name "-exec") + name))) + #t) + +(define* (build-image lisp image #:key inputs + (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 + #:dependencies dependencies + #:entry-program '(nil) + #:type "image") + (let* ((name (basename image)) + (bin-directory (dirname image))) + (with-directory-excursion bin-directory + (rename-file (string-append name "-exec--all-systems.image") + (string-append name ".image")))) + #t) + +(define* (generate-executable lisp out-file #:key inputs + dependencies + entry-program + type + #:allow-other-keys) + "Generate an executable by using asdf's TYPE-op, containing whithin the +image all DEPENDENCIES, and running ENTRY-PROGRAM in the case of an +executable." + (let* ((bin-directory (dirname out-file)) + (name (basename out-file))) + (mkdir-p bin-directory) + (with-directory-excursion bin-directory + (generate-executable-wrapper-system name dependencies) + (generate-executable-entry-point name entry-program)) + + (prepend-to-source-registry + (string-append bin-directory "/")) + + (setenv "ASDF_OUTPUT_TRANSLATIONS" + (replace-escaped-macros + (format + #f "~S" + (wrap-output-translations + `(((,bin-directory :**/ :*.*.*) + (,bin-directory :**/ :*.*.*))))))) + + (parameterize ((%lisp (string-append + (assoc-ref inputs lisp) "/bin/" lisp))) + (generate-executable-for-system type name lisp)) + + (delete-file (string-append bin-directory "/" name "-exec.asd")) + (delete-file (string-append bin-directory "/" name "-exec.lisp"))))