TakeV
/
guix
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

build-system: Add 'guile-build-system'. 

* 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'.
This commit is contained in:
Ludovic Courtès 2018-07-18 15:38:51 +02:00
parent a2908f5aae
commit 2a3b1b3235
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
4 changed files with 372 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile.am
View File

@ -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 \

15
doc/guix.texi
View File

@ -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.

202
guix/build-system/guile.scm Normal file
View File

@ -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)))

153
guix/build/guile-build-system.scm Normal file
View File

@ -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))