diff options
| -rw-r--r-- | Makefile.am | 2 | ||||
| -rw-r--r-- | doc/guix.texi | 15 | ||||
| -rw-r--r-- | guix/build-system/guile.scm | 202 | ||||
| -rw-r--r-- | guix/build/guile-build-system.scm | 153 |
4 files changed, 372 insertions, 0 deletions
diff --git a/Makefile.am b/Makefile.am index 6733f4f894..b4cd07ed22 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 84347d156b..f9b3ef0e55 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 +@defvr {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 +@file{configure} 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. +@end 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 0000000000..77a5f00b01 --- /dev/null +++ b/guix/build-system/guile.scm @@ -0,0 +1,202 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Ludovic Courtès <ludo@gnu.org> +;;; +;;; 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 0000000000..0bed049436 --- /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 <ludo@gnu.org> +;;; +;;; 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)) |