[v2,01/13] build-system: Add asdf-build-system.
Commit Message
* 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
Comments
Hi! I have spent more time wondering on this patch and ASDF, so here
are some questions, opinions and ideas (roughly).
Andy Patterson <ajpatter@uwaterloo.ca> writes:
> * 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.
Should be: Makefile.am (MODULES): Add them.
> * doc/guix.texi: Add section on 'asdf-build-system/source'.
Well, it dosen't create a new info section, I think this can be:
* doc/guix.texi (Build Systems): Document 'asdf-build-system'.
> ---
> 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 = \
> 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 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
>
> @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 sbcl)}, implement
Typo, sbcl -> asdf.
> +build procedures for Common Lisp packages using the
> +@url{https://common-lisp.net/project/asdf/, ``ASDF''} system.
How about expand it a bit to: @url{..., ``ASDF''}, 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 conventions to determine the roles of inputs in
> +the build system.
… uses naming conventions … What’s the “roles of inputs” for?
> 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
This is a bit confusing, so every input starts with ‘sbcl-’ will be
propagated? I wonder why not just use ‘propgated-inputs’ for that.
> +
> +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.
This is for binary packages right? (It’s obviously not convenient for
source packages which usually have an extra system for test only.)
++ I seems wrong here, new ideas below ‘package-with-build-system’. ++
For binary packages, this will be perfect if they’re 1-to-1 mapped to
a CL system, but then their names are inconsistent with the ’cl-’
ones, whose names are from projects instead of the systems they
contain.
Consider the ‘cl-autowrap’ (https://github.com/rpav/cl-autowrap)
project. It has 3 systems: ‘cl-autowrap’, ‘cl-autowrap-test’ and
‘cl-plus-c’. IIUC, follow this one package per system way, we will
package it as:
- cl-autowrap, contains the 3 systems in source form.
- sbcl-autowrap (or maybe sbcl-cl-autowrap?).
- sbcl-plus-c (or ‘sbcl-cl-plus-c?).
- sbcl-autowrap-test (for testing).
It’s hard to know that ‘cl-autowrap’ has ‘cl-plus-c’ in it…
> +
> +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.
I’d like to make the build action of ‘program’ or ‘image’ more
explicit instead of coding them in the build system. eg:
--8<---------------cut here---------------start------------->8---
(define-public sbcl-stumpwm
(package
…
(arguments
'(#:phases
(modify-phases %standard-phases
(add-after 'install 'install-program
(lambda* (#:key outputs #:allow-other-keys)
((let* ((bin (assoc-ref outputs "bin"))
(prog (string-append bin "/bin/stumpwm")))
(asdf:build-program prog
#:entry-program '((stumpwm:stumpwm))
#:special-dependencies '("sb-posix")))))))
…))))
--8<---------------cut here---------------end--------------->8---
I think this way show what #:entry-program and other parameters are used
for more clearly, as they have nothing to do with other phases (compile
the system and install a bundle asd file). Most CL packages are
libraries, so I feel that having phases (generate-binary and
generate-image) which do nothing most times is overkill :-)
What’s the ‘compile-dependencies’ used for? I think when compile a
system, ASDF will load all its depends (from the :depends-on) first.
Sometimes we need load extra systems manually?
> […]
> 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 @@
> […]
> +
> +(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.
Oops, so we should use one package per system for source packages too,
otherwise there is no obvious way to transform between them (I’d like it
be one way, just ‘cl-package->sbcl-package’) and binary packages. If
that’s true, for the ‘cl-autowrap’ project, its source packages should
be ‘cl-autowrap’, ’cl-plus-c’, and ‘cl-autowrap-test’. And I don’t
think we should copy the whole project source for each of them. So, how
about:
- For a CL project, define a (non-public) project package, which just
unpacks the source to its ‘$out’.
- For each system the project contains, define a ‘cl-SYSTEM-NAME-W/O-CL’
package, which takes the project package as ‘source’ and symlink the
system’s asd file to its ‘$out/share/common-lisp/systems’.
- Then for each ‘cl-’ package, we can transform it to a binary package,
which should compile and install a bundle asd file for one system.
> +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.
A symbol?
> +
> +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/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) 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))))
To make a binary package from a source package, my plan looks like:
- remove all inputs not start with ‘cl-’. Ideally, we can do all the
things (eg: patch the file names of ffi libraries to absolute paths)
in source packages to make them ready to use for CLs. All a binary
package needs are CL systems and an CL compiler.
- rewrite ‘cl-’ inputs to ‘sbcl-’ inputs recursively.
- source package becomes the ‘source’ of the binary package, if in-tree
build is needed (I hope not very often), we can follow the asd file
link to copy its real source.
> +
> + (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)))
If we don’t allow ‘sbcl-package->cl-package’, arguments don’t need to be
stripped.
> +
> + (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 ''())
> + (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
> + #:compile-dependencies ,compile-dependencies
> + #:test-only-systems ,test-only-systems
++ quetions below ‘patch-asd-files’. ++
> + #:entry-program ,entry-program
> + #:image-dependencies ,image-dependencies
> + #:image? ,image?
> + #:binary? ,binary?
Those will be removed if we build ‘program’ or ’image’ explicitly. In
that case, IIUC, we should add variant properties to the source package
if we add phases (by inherit) to the binary package and want the
transform get the same (not get the same one is fine too, which only
lacks the optional programs or binaries) package.
> + #: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 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)))
The ‘source-phases->sbcl-phases’ proceduce seems missing, is it ‘(const
%standard-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
> […]
> +(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 only
> +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=? 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)
Doesn’t ‘special-dependencies’ always available, do we need load them
explicitly?
I think it’s strange that ‘deliver-asd-op’ make a asd file without all
its original depends, if the original are valid, maybe we can copy them
back?
> […]
> +(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 package
> +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=>
> + (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 \"image\"
> +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=>
> + (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 the
> +image all IMAGE-DEPNDENCIES, and running ENTRY-PROGRAM in the case of an
> +executable."
> + (and=>
> + (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"))))))
> +
Yeah, I’d like to merge those into lisp-utils.scm, and become something
like ‘wrap-program’.
Also, the output-translations way sometime produces unnecessary
files, eg: in ecl-fiveam:
--8<---------------cut here---------------start------------->8---
/gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib
/gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib/ecl
/gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib/ecl/src
/gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib/ecl/src/fiveam.fasb
/gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib/ecl/src/fiveam.asd
/gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib/ecl/src/fiveam.a
/gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib/ecl/t
--8<---------------cut here---------------end--------------->8---
I think we only want ’lib/ecl/fiveam.*’.
I have tried ‘asdf/action:output-files’, hoping that will allow install
only the files we want, but it doesn’t seem give all the output files.
Run this with ECL:
--8<---------------cut here---------------start------------->8---
(require :asdf)
(let* ((asdf/output-translations:*output-translations*
'(((t #P"/tmp/build/**/*.*"))))
(files
(asdf/action:output-files
'asdf:compile-bundle-op (asdf:find-system :cl-json))))
(asdf:operate 'asdf:compile-bundle-op :cl-json)
(format t "~S" files))
(quit)
--8<---------------cut here---------------end--------------->8---
The ‘fasb’ file is returned, but the ‘a’ file is missing.
What the ECL lib (‘a’) files used for?
Despite my opinions and ideas, please let me know if this patch is
considered ready, so we can merge it and improve later.
Thanks!
On Wed, 05 Oct 2016 12:55:51 +0800
iyzsong@member.fsf.org (宋文武) wrote:
> Hi! I have spent more time wondering on this patch and ASDF, so here
> are some questions, opinions and ideas (roughly).
>
Hi. Thanks again for your comments.
> > * Makefile.am: Add them.
>
> Should be: Makefile.am (MODULES): Add them.
>
Ok.
> > * doc/guix.texi: Add section on 'asdf-build-system/source'.
>
> Well, it dosen't create a new info section, I think this can be:
>
> * doc/guix.texi (Build Systems): Document 'asdf-build-system'.
>
Ok.
> > +These variables, exported by @code{(guix build-system sbcl)},
> > implement
>
> Typo, sbcl -> asdf.
>
Right.
> > +build procedures for Common Lisp packages using the
> > +@url{https://common-lisp.net/project/asdf/, ``ASDF''} system.
>
> How about expand it a bit to: @url{..., ``ASDF''}, a system definition
> facility for Common Lisp programs and libraries.
>
Sure.
> > +The build system uses conventions to determine the roles of inputs
> > in +the build system.
>
> … uses naming conventions … What’s the “roles of inputs” for?
>
I'll explain what is meant a bit further.
> > + For example,
> > +
> > +@example
> > +(define-public sbcl-bordeaux-threads
> > + (package
> > + ...
> > + (native-inputs `(("tests:cl-fiveam" ,sbcl-fiveam)))
> > + ...))
> > +@end example
>
> This is a bit confusing, so every input starts with ‘sbcl-’ will be
> propagated? I wonder why not just use ‘propgated-inputs’ for that.
>
Packages aren't propagated in the binary systems. The naming
convention is what tells 'patch-asd-file' which systems to wrap the
library with (so that it can find its dependencies). Changing the
prefix will cause that phase to ignore that library, so doing so has
the same effect as '#:test-only-systems' used to have. I'll explain
that in the doc.
> > +
> > +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.
>
> This is for binary packages right? (It’s obviously not convenient for
> source packages which usually have an extra system for test only.)
> ++ I seems wrong here, new ideas below ‘package-with-build-system’. ++
>
This is correct, actually. This is essentially what I did for slynk,
which contains quite a few systems.
> For binary packages, this will be perfect if they’re 1-to-1 mapped to
> a CL system, but then their names are inconsistent with the ’cl-’
> ones, whose names are from projects instead of the systems they
> contain.
>
> Consider the ‘cl-autowrap’ (https://github.com/rpav/cl-autowrap)
> project. It has 3 systems: ‘cl-autowrap’, ‘cl-autowrap-test’ and
> ‘cl-plus-c’. IIUC, follow this one package per system way, we will
> package it as:
>
> - cl-autowrap, contains the 3 systems in source form.
> - sbcl-autowrap (or maybe sbcl-cl-autowrap?).
> - sbcl-plus-c (or ‘sbcl-cl-plus-c?).
> - sbcl-autowrap-test (for testing).
>
That's right (and it would be sbcl-cl-autowrap).
> It’s hard to know that ‘cl-autowrap’ has ‘cl-plus-c’ in it…
>
In that case, we could add the extra systems to the description of the
source package. Does that sound reasonable?
> > +
> > +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.
>
> I’d like to make the build action of ‘program’ or ‘image’ more
> explicit instead of coding them in the build system. eg:
>
> --8<---------------cut here---------------start------------->8---
> (define-public sbcl-stumpwm
> (package
> …
> (arguments
> '(#:phases
> (modify-phases %standard-phases
> (add-after 'install 'install-program
> (lambda* (#:key outputs #:allow-other-keys)
> ((let* ((bin (assoc-ref outputs "bin"))
> (prog (string-append bin "/bin/stumpwm")))
> (asdf:build-program prog
> #:entry-program '((stumpwm:stumpwm))
> #:special-dependencies '("sb-posix")))))))
> …))))
> --8<---------------cut here---------------end--------------->8---
>
> I think this way show what #:entry-program and other parameters are
> used for more clearly, as they have nothing to do with other phases
> (compile the system and install a bundle asd file). Most CL packages
> are libraries, so I feel that having phases (generate-binary and
> generate-image) which do nothing most times is overkill :-)
>
That sounds good.
> What’s the ‘compile-dependencies’ used for? I think when compile a
> system, ASDF will load all its depends (from the :depends-on) first.
> Sometimes we need load extra systems manually?
>
It's for packages like slynk, where many systems are defined within the
same file. When telling asdf to find a system, it will only search for
a file with the same name unless it already knows about that system.
Therefore, in these cases the system which contains the definitions is
loaded first. This mechanism is a bit clunky so suggestions are
welcome. For now I'll document the reason it's done that way.
> > […]
> > 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 @@
> > […]
> > +
> > +(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.
>
> Oops, so we should use one package per system for source packages too,
> otherwise there is no obvious way to transform between them (I’d like
> it be one way, just ‘cl-package->sbcl-package’) and binary packages.
There doesn't need to be a translation for each package; in the case of
slynk one translation is done for sbcl->cl-source, and then the other
systems provided have binary packages created just using the usual
inherit mechanism, and a translation is made for sbcl->ecl.
I decided to use the sbcl package a the source for all translations,
because it is likely that a binary package will contain more
information (in the form of customizations to the arguments field),
than for source packages, which simplifies the translation process.
> If that’s true, for the ‘cl-autowrap’ project, its source packages
> should be ‘cl-autowrap’, ’cl-plus-c’, and ‘cl-autowrap-test’. And I
> don’t think we should copy the whole project source for each of
> them. So, how about:
>
I agree, that seems unnecessary.
> - For a CL project, define a (non-public) project package, which just
> unpacks the source to its ‘$out’.
>
> - For each system the project contains, define a
> ‘cl-SYSTEM-NAME-W/O-CL’ package, which takes the project package as
> ‘source’ and symlink the system’s asd file to its
> ‘$out/share/common-lisp/systems’.
>
The source package already copies all asd files to that directory, so
I think it makes sense to have just one source package (I'll fix the
documentation for that). So for the case of cl-autowrap, that
directory would contain cl-{autowrap-test,autowrap,plus-c}.asd.
In the guix source, you'd have a sbcl-cl-autowrap package, an
automatically translated cl-autowrap package containing all of the
above, and a manually inherited sbcl-cl-plus-c package. There wouldn't
be a -test package. You'd then also have automatically translated ecl-
packages.
> - Then for each ‘cl-’ package, we can transform it to a binary
> package, which should compile and install a bundle asd file for one
> system.
>
As described earlier, I think it's easier to go binary->source and
binary->binary.
> > +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.
>
> A symbol?
>
Right, it could be any quoted sexp. I'll fix that.
> To make a binary package from a source package, my plan looks like:
>
> - remove all inputs not start with ‘cl-’. Ideally, we can do all the
> things (eg: patch the file names of ffi libraries to absolute paths)
> in source packages to make them ready to use for CLs. All a binary
> package needs are CL systems and an CL compiler.
>
Correct; that's currently exactly what CL systems depend on. I'm hoping
that patching ffi files could be done in a mostly automated way once
that's required, so that copying build phases would be unnecessary.
> - rewrite ‘cl-’ inputs to ‘sbcl-’ inputs recursively.
>
> - source package becomes the ‘source’ of the binary package, if
> in-tree build is needed (I hope not very often), we can follow the
> asd file link to copy its real source.
>
I think it's more flexible to just always build in tree (the system
worked as you describe it here in the first version of the series).
It's not too outlandish to think that systems might want to create
files during the test phase, which is exactly what one package was
doing.
> > +
> > + (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)))
>
> If we don’t allow ‘sbcl-package->cl-package’, arguments don’t need to
> be stripped.
>
That's true, but it's easier to strip arguments than to add them.
> ++ quetions below ‘patch-asd-files’. ++
>
> > + #:entry-program ,entry-program
> > + #:image-dependencies ,image-dependencies
> > + #:image? ,image?
> > + #:binary? ,binary?
>
>
> Those will be removed if we build ‘program’ or ’image’ explicitly. In
> that case, IIUC, we should add variant properties to the source
> package if we add phases (by inherit) to the binary package and want
> the transform get the same (not get the same one is fine too, which
> only lacks the optional programs or binaries) package.
>
>
That's correct.
> > +(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)))
>
> The ‘source-phases->sbcl-phases’ proceduce seems missing, is it
> ‘(const %standard-phases)’?
>
I meant to delete that procedure.
> Doesn’t ‘special-dependencies’ always available, do we need load them
> explicitly?
>
The problem is that the asd file produced by 'deliver-asd-op' doesn't
add anything to :depends-on, as you mention.
> I think it’s strange that ‘deliver-asd-op’ make a asd file without all
> its original depends, if the original are valid, maybe we can copy
> them back?
>
That's basically what's being done in a slightly roundabout way. The
key thing is that we let asdf know where the dependencies need to be
found first, so that we can avoid propagation. Copying the :depends-on
field could be difficult since it can contain reader expressions. We'd
need some logic to do that, or have a lisp implementation help us out.
I don't think specifying #:special-dependencies is too onerous; the
package creator is required to specify dependencies anyway.
> > […]
> > +(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 package +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=>
> > + (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 \"image\" +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=>
> > + (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 the +image all IMAGE-DEPNDENCIES, and running ENTRY-PROGRAM
> > in the case of an +executable."
> > + (and=>
> > + (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"))))))
> > +
>
> Yeah, I’d like to merge those into lisp-utils.scm, and become
> something like ‘wrap-program’.
>
Ok, sounds good.
>
> Also, the output-translations way sometime produces unnecessary
> files, eg: in ecl-fiveam:
>
> --8<---------------cut here---------------start------------->8---
> /gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib
> /gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib/ecl
> /gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib/ecl/src
> /gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib/ecl/src/fiveam.fasb
> /gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib/ecl/src/fiveam.asd
> /gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib/ecl/src/fiveam.a
> /gnu/store/jy5525lyx0lk20h02g6ik5q4qfkjcnz6-ecl-fiveam-1.2/lib/ecl/t
> --8<---------------cut here---------------end--------------->8---
>
> I think we only want ’lib/ecl/fiveam.*’.
>
Right, I didn't notice that.
> I have tried ‘asdf/action:output-files’, hoping that will allow
> install only the files we want, but it doesn’t seem give all the
> output files.
>
> Run this with ECL:
>
> --8<---------------cut here---------------start------------->8---
> (require :asdf)
>
> (let* ((asdf/output-translations:*output-translations*
> '(((t #P"/tmp/build/**/*.*"))))
> (files
> (asdf/action:output-files
> 'asdf:compile-bundle-op (asdf:find-system :cl-json))))
> (asdf:operate 'asdf:compile-bundle-op :cl-json)
> (format t "~S" files))
>
> (quit)
> --8<---------------cut here---------------end--------------->8---
>
> The ‘fasb’ file is returned, but the ‘a’ file is missing.
> What the ECL lib (‘a’) files used for?
>
It gets created by the 'compile-bundle-op', so I assumed it was
necessary, but it turns out it's perfectly possible to load systems
without it. My guess is that it's just a convenience for C developpers,
and we don't really need it. It could be useful if we ever find a C
program that depends on ECL libraries, but I'm willing to remove it.
>
> Despite my opinions and ideas, please let me know if this patch is
> considered ready, so we can merge it and improve later.
The patch is in a working state, but I have no problem implementing
your suggestions and continuing discussion. It shouldn't take too long.
>
> Thanks!
Thank you.
--
Andy
@@ -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 \
@@ -2965,6 +2965,66 @@ 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 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
new file mode 100644
@@ -0,0 +1,385 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build-system asdf)
+ #:use-module (guix store)
+ #:use-module (guix utils)
+ #:use-module (guix packages)
+ #:use-module (guix derivations)
+ #:use-module (guix search-paths)
+ #:use-module (guix build-system)
+ #:use-module (guix build-system gnu)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-26)
+ #:export (%asdf-build-system-modules
+ %asdf-build-modules
+ asdf-build
+ asdf-build-system/sbcl
+ asdf-build-system/ecl
+ asdf-build-system/source
+ sbcl-package->cl-source-package
+ sbcl-package->ecl-package))
+
+;; Commentary:
+;;
+;; Standard build procedure for asdf packages. This is implemented as an
+;; extension of 'gnu-build-system'.
+;;
+;; Code:
+
+(define %asdf-build-system-modules
+ ;; Imported build-side modules
+ `((guix build asdf-build-system)
+ (guix build lisp-utils)
+ ,@%gnu-build-system-modules))
+
+(define %asdf-build-modules
+ ;; Used (visible) build-side modules
+ '((guix build asdf-build-system)
+ (guix build utils)
+ (guix build lisp-utils)))
+
+(define (default-lisp implementation)
+ "Return the default package for the lisp IMPLEMENTATION."
+ ;; Lazily resolve the binding to avoid a circular dependancy.
+ (let ((lisp-module (resolve-interface '(gnu packages lisp))))
+ (module-ref lisp-module implementation)))
+
+(define* (lower/source name
+ #:key source inputs outputs native-inputs system target
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME"
+ (define private-keywords
+ '(#:target #:inputs #:native-inputs))
+
+ (and (not target)
+ (bag
+ (name name)
+ (system system)
+ (host-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@inputs
+ ,@(standard-packages)))
+ (build-inputs native-inputs)
+ (outputs outputs)
+ (build asdf-build/source)
+ (arguments (strip-keyword-arguments private-keywords arguments)))))
+
+(define* (asdf-build/source store name inputs
+ #:key source outputs
+ (phases '(@ (guix build asdf-build-system)
+ %standard-phases/source))
+ (search-paths '())
+ (system (%current-system))
+ (guile #f)
+ (imported-modules %asdf-build-system-modules)
+ (modules %asdf-build-modules))
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (asdf-build/source #:name ,name
+ #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source) source)
+ (source source))
+ #:system ,system
+ #:phases ,phases
+ #:outputs %outputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:inputs %build-inputs)))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f
+ (let* ((distro (resolve-interface '(gnu packages commencement)))
+ (guile (module-ref distro 'guile-final)))
+ (package-derivation store guile system #:graft? #f)))))
+
+ (build-expression->derivation store name builder
+ #:inputs inputs
+ #:system system
+ #:modules imported-modules
+ #:outputs outputs
+ #:guile-for-build guile-for-build))
+
+(define* (package-with-build-system from-build-system to-build-system
+ from-prefix to-prefix
+ #:key variant-property
+ phases-transformer)
+ "Return a precedure which takes a package PKG which uses FROM-BUILD-SYSTEM,
+and returns one using TO-BUILD-SYSTEM. If PKG was prefixed by FROM-PREFIX, the
+resulting package will be prefixed by TO-PREFIX. Inputs of PKG are recursively
+transformed using the same rule. The result's #:phases argument will be
+modified by PHASES-TRANSFORMER, 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 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/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) 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 #: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))
+ => 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 ''())
+ (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->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 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
new file mode 100644
@@ -0,0 +1,400 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build 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 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 (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 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
+ 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 only
+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=? 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 package
+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=>
+ (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 \"image\"
+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=>
+ (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 the
+image all IMAGE-DEPNDENCIES, and running ENTRY-PROGRAM in the case of an
+executable."
+ (and=>
+ (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 systems
+ (unless (string=? 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
new file mode 100644
@@ -0,0 +1,240 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Andy Patterson <ajpatter@uwaterloo.ca>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build 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 wrapper
+;;; systems for executables. Compile, test, and produce images for systems 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 program
+inside the current directory. The image or program will contain SYSTEM and all
+other DEPENDENCIES, which may not be depended on by the SYSTEM itself. SYSTEM
+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 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/lib/LISP/<system>.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))