[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[bug#32205] [PATCH 1/3] build-system: Add 'guile-build-system'.
|
From: |
Ludovic Courtès |
|
Subject: |
[bug#32205] [PATCH 1/3] build-system: Add 'guile-build-system'. |
|
Date: |
Wed, 18 Jul 2018 23:20:41 +0200 |
* guix/build-system/guile.scm, guix/build/guile-build-system.scm: New
files.
* Makefile.am (MODULES): Add them.
* doc/guix.texi (Build Systems): Document 'guile-build-system'.
---
Makefile.am | 2 +
doc/guix.texi | 15 +++
guix/build-system/guile.scm | 202 ++++++++++++++++++++++++++++++
guix/build/guile-build-system.scm | 153 ++++++++++++++++++++++
4 files changed, 372 insertions(+)
create mode 100644 guix/build-system/guile.scm
create mode 100644 guix/build/guile-build-system.scm
diff --git a/Makefile.am b/Makefile.am
index 6733f4f89..b4cd07ed2 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -111,6 +111,7 @@ MODULES = \
guix/build-system/asdf.scm \
guix/build-system/glib-or-gtk.scm \
guix/build-system/gnu.scm \
+ guix/build-system/guile.scm \
guix/build-system/haskell.scm \
guix/build-system/perl.scm \
guix/build-system/python.scm \
@@ -149,6 +150,7 @@ MODULES = \
guix/build/glib-or-gtk-build-system.scm \
guix/build/gnu-build-system.scm \
guix/build/gnu-dist.scm \
+ guix/build/guile-build-system.scm \
guix/build/perl-build-system.scm \
guix/build/python-build-system.scm \
guix/build/ocaml-build-system.scm \
diff --git a/doc/guix.texi b/doc/guix.texi
index 84347d156..f9b3ef0e5 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -4045,6 +4045,21 @@ specified with the @code{#:glib} parameter.
Both phases are executed after the @code{install} phase.
@end defvr
address@hidden {Scheme Variable} guile-build-system
+This build system is for Guile packages that consist exclusively of Scheme
+code and that are so lean that they don't even have a makefile, let alone a
address@hidden script. It compiles Scheme code using @command{guild
+compile} (@pxref{Compilation,,, guile, GNU Guile Reference Manual}) and
+installs the @file{.scm} and @file{.go} files in the right place. It also
+installs documentation.
+
+This build system supports cross-compilation by using the @code{--target}
+option of @command{guild compile}.
+
+Packages built with @code{guile-build-system} must provide a Guile package in
+their @code{native-inputs} field.
address@hidden defvr
+
@defvr {Scheme Variable} minify-build-system
This variable is exported by @code{(guix build-system minify)}. It
implements a minification procedure for simple JavaScript packages.
diff --git a/guix/build-system/guile.scm b/guix/build-system/guile.scm
new file mode 100644
index 000000000..77a5f00b0
--- /dev/null
+++ b/guix/build-system/guile.scm
@@ -0,0 +1,202 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <address@hidden>
+;;;
+;;; 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 guile)
+ #: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 (srfi srfi-26)
+ #:export (%guile-build-system-modules
+ guile-build-system))
+
+(define %guile-build-system-modules
+ ;; Build-side modules imported by default.
+ `((guix build guile-build-system)
+ ,@%gnu-build-system-modules))
+
+(define* (lower name
+ #:key source inputs native-inputs outputs system target
+ #:allow-other-keys
+ #:rest arguments)
+ "Return a bag for NAME."
+
+ ;; Note: There's no #:guile argument (unlike, for instance,
+ ;; 'ocaml-build-system' which has #:ocaml.) This is so we can keep
+ ;; procedures like 'package-for-guile-2.0' unchanged and simple.
+
+ (define private-keywords
+ '(#:target #:inputs #:native-inputs))
+
+ (bag
+ (name name)
+ (system system) (target target)
+ (host-inputs `(
+ ,@inputs))
+ (build-inputs `(,@(if source
+ `(("source" ,source))
+ '())
+ ,@native-inputs
+ ,@(map (cute assoc <> (standard-packages))
+ '("tar" "gzip" "bzip2" "xz" "locales"))))
+ (outputs outputs)
+ (build (if target guile-cross-build guile-build))
+ (arguments (strip-keyword-arguments private-keywords arguments))))
+
+(define %compile-flags
+ ;; Flags passed to 'guild compile' by default. We choose a common
+ ;; denominator between Guile 2.0 and 2.2.
+ ''("-Wunbound-variable" "-Warity-mismatch" "-Wformat"))
+
+(define* (guile-build store name inputs
+ #:key source
+ (guile #f)
+ (phases '%standard-phases)
+ (outputs '("out"))
+ (search-paths '())
+ (system (%current-system))
+ (source-directory ".")
+ (compile-flags %compile-flags)
+ (imported-modules %guile-build-system-modules)
+ (modules '((guix build guile-build-system)
+ (guix build utils))))
+ "Build SOURCE using Guile taken from the native inputs, and with INPUTS."
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+ (guile-build #:name ,name
+ #:source ,(match (assoc-ref inputs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:source-directory ,source-directory
+ #:compile-flags ,compile-flags
+ #:phases ,phases
+ #:system ,system
+ #: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 ; the default
+ (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* (guile-cross-build store name
+ #:key
+ (system (%current-system)) target
+ native-drvs target-drvs
+ (guile #f)
+ source
+ (outputs '("out"))
+ (search-paths '())
+ (native-search-paths '())
+
+ (phases '%standard-phases)
+ (source-directory ".")
+ (compile-flags %compile-flags)
+ (imported-modules %guile-build-system-modules)
+ (modules '((guix build guile-build-system)
+ (guix build utils))))
+ (define builder
+ `(begin
+ (use-modules ,@modules)
+
+ (let ()
+ (define %build-host-inputs
+ ',(map (match-lambda
+ ((name (? derivation? drv) sub ...)
+ `(,name . ,(apply derivation->output-path drv sub)))
+ ((name path)
+ `(,name . ,path)))
+ native-drvs))
+
+ (define %build-target-inputs
+ ',(map (match-lambda
+ ((name (? derivation? drv) sub ...)
+ `(,name . ,(apply derivation->output-path drv sub)))
+ ((name (? package? pkg) sub ...)
+ (let ((drv (package-cross-derivation store pkg
+ target system)))
+ `(,name . ,(apply derivation->output-path drv sub))))
+ ((name path)
+ `(,name . ,path)))
+ target-drvs))
+
+ (guile-build #:source ,(match (assoc-ref native-drvs "source")
+ (((? derivation? source))
+ (derivation->output-path source))
+ ((source)
+ source)
+ (source
+ source))
+ #:system ,system
+ #:target ,target
+ #:outputs %outputs
+ #:source-directory ,source-directory
+ #:compile-flags ,compile-flags
+ #:inputs %build-target-inputs
+ #:native-inputs %build-host-inputs
+ #:search-paths ',(map search-path-specification->sexp
+ search-paths)
+ #:native-search-paths ',(map
+ search-path-specification->sexp
+ native-search-paths)
+ #:phases ,phases))))
+
+ (define guile-for-build
+ (match guile
+ ((? package?)
+ (package-derivation store guile system #:graft? #f))
+ (#f ; the default
+ (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
+ #:system system
+ #:inputs (append native-drvs target-drvs)
+ #:outputs outputs
+ #:modules imported-modules
+ #:substitutable? substitutable?
+ #:guile-for-build guile-for-build))
+
+(define guile-build-system
+ (build-system
+ (name 'guile)
+ (description "The build system for simple Guile packages")
+ (lower lower)))
diff --git a/guix/build/guile-build-system.scm
b/guix/build/guile-build-system.scm
new file mode 100644
index 000000000..0bed04943
--- /dev/null
+++ b/guix/build/guile-build-system.scm
@@ -0,0 +1,153 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2018 Ludovic Courtès <address@hidden>
+;;;
+;;; 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 guile-build-system)
+ #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build utils)
+ #:use-module (srfi srfi-26)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 rdelim)
+ #:use-module (guix build utils)
+ #:export (target-guile-effective-version
+ %standard-phases
+ guile-build))
+
+(define* (target-guile-effective-version #:optional guile)
+ "Return the effective version of GUILE or whichever 'guile' is in $PATH.
+Return #false if it cannot be determined."
+ (let* ((pipe (open-pipe* OPEN_READ
+ (if guile
+ (string-append guile "/bin/guile")
+ "guile")
+ "-c" "(display (effective-version))"))
+ (line (read-line pipe)))
+ (and (zero? (close-pipe pipe))
+ (string? line)
+ line)))
+
+(define (file-sans-extension file) ;TODO: factorize
+ "Return the substring of FILE without its extension, if any."
+ (let ((dot (string-rindex file #\.)))
+ (if dot
+ (substring file 0 dot)
+ file)))
+
+(define %scheme-file-regexp
+ ;; Regexp to match Scheme files.
+ "\\.(scm|sls)$")
+
+(define %documentation-file-regexp
+ ;; Regexp to match README files and the likes.
+ "^(README.*|.*\\.html|.*\\.org|.*\\.md)$")
+
+(define* (set-locale-path #:key inputs native-inputs
+ #:allow-other-keys)
+ "Set 'GUIX_LOCPATH'."
+ (match (assoc-ref (or native-inputs inputs) "locales")
+ (#f #t)
+ (locales
+ (setenv "GUIX_LOCPATH" (string-append locales "/lib/locale"))
+ #t)))
+
+(define* (build #:key outputs inputs native-inputs
+ (source-directory ".")
+ (compile-flags '())
+ (scheme-file-regexp %scheme-file-regexp)
+ target
+ #:allow-other-keys)
+ "Build files in SOURCE-DIRECTORY that match SCHEME-FILE-REGEXP."
+ (let* ((out (assoc-ref outputs "out"))
+ (guile (assoc-ref (or native-inputs inputs) "guile"))
+ (effective (target-guile-effective-version guile))
+ (module-dir (string-append out "/share/guile/site/"
+ effective))
+ (go-dir (string-append out "/lib/guile/"
+ effective "/site-ccache/"))
+ (guild (string-append guile "/bin/guild"))
+ (flags (if target
+ (cons (string-append "--target=" target)
+ compile-flags)
+ compile-flags)))
+ (if target
+ (format #t "Cross-compiling for '~a' with Guile ~a...~%"
+ target effective)
+ (format #t "Compiling with Guile ~a...~%" effective))
+ (format #t "compile flags: ~s~%" flags)
+
+ ;; Make installation directories.
+ (mkdir-p module-dir)
+ (mkdir-p go-dir)
+
+ ;; Compile .scm files and install.
+ (setenv "GUILE_AUTO_COMPILE" "0")
+ (setenv "GUILE_LOAD_COMPILED_PATH"
+ (string-append go-dir
+ (match (getenv "GUILE_LOAD_COMPILED_PATH")
+ (#f "")
+ (path (string-append ":" path)))))
+ (for-each (lambda (file)
+ (let* ((go (string-append go-dir
+ (file-sans-extension file)
+ ".go")))
+ ;; Install source module.
+ (install-file (string-append source-directory "/" file)
+ (string-append module-dir
+ "/" (dirname file)))
+
+ ;; Install and compile module.
+ (apply invoke guild "compile" "-L" source-directory
+ "-o" go
+ (string-append source-directory "/" file)
+ flags)))
+
+ ;; Arrange to strip SOURCE-DIRECTORY from file names.
+ (with-directory-excursion source-directory
+ (find-files "." scheme-file-regexp)))
+ #t))
+
+(define* (install-documentation #:key outputs
+ (documentation-file-regexp
+ %documentation-file-regexp)
+ #:allow-other-keys)
+ "Install files that mactch DOCUMENTATION-FILE-REGEXP."
+ (let* ((out (assoc-ref outputs "out"))
+ (doc (string-append out "/share/doc/"
+ (strip-store-file-name out))))
+ (for-each (cut install-file <> doc)
+ (find-files "." documentation-file-regexp))
+ #t))
+
+(define %standard-phases
+ (modify-phases gnu:%standard-phases
+ (delete 'bootstrap)
+ (delete 'configure)
+ (add-before 'install-locale 'set-locale-path
+ set-locale-path)
+ (replace 'build build)
+ (add-after 'build 'install-documentation
+ install-documentation)
+ (delete 'check)
+ (delete 'strip)
+ (delete 'validate-runpath)
+ (delete 'install)))
+
+(define* (guile-build #:key (phases %standard-phases)
+ #:allow-other-keys #:rest args)
+ "Build the given Guile package, applying all of PHASES in order."
+ (apply gnu:gnu-build #:phases phases args))
--
2.18.0