diff options
Diffstat (limited to 'guix/build')
| -rw-r--r-- | guix/build/android-ndk-build-system.scm | 88 | ||||
| -rw-r--r-- | guix/build/ant-build-system.scm | 20 | ||||
| -rw-r--r-- | guix/build/compile.scm | 45 | ||||
| -rw-r--r-- | guix/build/emacs-utils.scm | 4 | ||||
| -rw-r--r-- | guix/build/profiles.scm | 14 | ||||
| -rw-r--r-- | guix/build/r-build-system.scm | 27 | ||||
| -rw-r--r-- | guix/build/union.scm | 65 |
7 files changed, 230 insertions, 33 deletions
diff --git a/guix/build/android-ndk-build-system.scm b/guix/build/android-ndk-build-system.scm new file mode 100644 index 0000000000..3c8f726d1d --- /dev/null +++ b/guix/build/android-ndk-build-system.scm @@ -0,0 +1,88 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2018 Danny Milosavljevic <dannym@scratchpost.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 android-ndk-build-system) + #:use-module ((guix build gnu-build-system) #:prefix gnu:) + #:use-module (guix build syscalls) + #:use-module (guix build utils) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 ftw) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (rnrs io ports) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:export (%standard-phases + android-ndk-build)) + +;; Commentary: +;; +;; Builder-side code of the Android NDK build system. +;; +;; Code: + +(define* (configure #:key inputs outputs #:allow-other-keys) + (let ((library-directories (filter-map (match-lambda + ((name . path) + (if (eq? 'directory (stat:type (stat path))) + path + #f))) + inputs))) + (setenv "CC" "gcc") + (setenv "CXX" "g++") + (setenv "CPPFLAGS" + (string-join + (map (cut string-append "-I " <> "/include") library-directories) + " ")) + (setenv "LDFLAGS" + (string-append "-L . " + (string-join + (map (lambda (x) + (string-append "-L " x "/lib" " -Wl,-rpath=" x "/lib")) + library-directories) + " "))) + #t)) + +(define* (install #:key inputs outputs (make-flags '()) #:allow-other-keys) + (let ((out (assoc-ref outputs "out"))) + (apply invoke "make" "install" + (string-append "prefix=" out) + make-flags) + #t)) + +(define* (check #:key target inputs outputs (tests? (not target)) (make-flags '()) #:allow-other-keys) + (if tests? + (begin + (apply invoke "make" "check" make-flags) + (when (and (file-exists? "tests") tests?) + (with-directory-excursion "tests" + (apply invoke "make" "check" make-flags)))) + (format #t "test suite not run~%")) + #t) + +(define %standard-phases + (modify-phases gnu:%standard-phases + (replace 'configure configure) + (replace 'install install) + (replace 'check check))) + +(define* (android-ndk-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + "Build the given Android NDK package, applying all of PHASES in order." + (apply gnu:gnu-build #:inputs inputs #:phases phases args)) diff --git a/guix/build/ant-build-system.scm b/guix/build/ant-build-system.scm index a6da530dab..d081a2b313 100644 --- a/guix/build/ant-build-system.scm +++ b/guix/build/ant-build-system.scm @@ -166,12 +166,26 @@ to the default GNU unpack strategy." "/share/java") source-dir test-dir main-class test-include test-exclude)) (setenv "JAVA_HOME" (assoc-ref inputs "jdk")) - (setenv "CLASSPATH" (generate-classpath inputs))) + (setenv "CLASSPATH" (generate-classpath inputs)) + #t) (define* (build #:key (make-flags '()) (build-target "jar") #:allow-other-keys) (zero? (apply system* `("ant" ,build-target ,@make-flags)))) +(define* (generate-jar-indices #:key outputs #:allow-other-keys) + "Generate file \"META-INF/INDEX.LIST\". This file does not use word wraps +and is preferred over \"META-INF/MAINFEST.MF\", which does use word wraps, +by Java when resolving dependencies. So we make sure to create it so that +grafting works - and so that the garbage collector doesn't collect +dependencies of this jar file." + (define (generate-index jar) + (invoke "jar" "-i" jar)) + (every (match-lambda + ((output . directory) + (every generate-index (find-files directory "\\.jar$")))) + outputs)) + (define* (strip-jar-timestamps #:key outputs #:allow-other-keys) "Unpack all jar archives, reset the timestamp of all contained files, and @@ -233,7 +247,9 @@ repack them. This is necessary to ensure that archives are reproducible." (replace 'build build) (replace 'check check) (replace 'install install) - (add-after 'install 'strip-jar-timestamps strip-jar-timestamps))) + (add-after 'install 'generate-jar-indices generate-jar-indices) + (add-after 'generate-jar-indices 'strip-jar-timestamps + strip-jar-timestamps))) (define* (ant-build #:key inputs (phases %standard-phases) #:allow-other-keys #:rest args) diff --git a/guix/build/compile.scm b/guix/build/compile.scm index 1bd8c60fe5..7b6e31107c 100644 --- a/guix/build/compile.scm +++ b/guix/build/compile.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2014, 2016, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2014, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Taylan Ulrich Bayırlı/Kammer <taylanbayirli@gmail.com> ;;; ;;; This file is part of GNU Guix. @@ -120,6 +120,28 @@ front." (lambda () (set! path initial-value))))) +(define (call/exit-on-exception thunk) + "Evaluate THUNK and exit right away if an exception is thrown." + (catch #t + thunk + (const #f) + (lambda (key . args) + (false-if-exception + ;; Duplicate stderr to avoid thread-safety issues. + (let* ((port (duplicate-port (current-error-port) "w0")) + (stack (make-stack #t)) + (depth (stack-length stack)) + (frame (and (> depth 1) (stack-ref stack 1)))) + (false-if-exception (display-backtrace stack port)) + (print-exception port frame key args))) + + ;; Don't go any further. + (primitive-exit 1)))) + +(define-syntax-rule (exit-on-exception exp ...) + "Evaluate EXP and exit if an exception is thrown." + (call/exit-on-exception (lambda () exp ...))) + (define* (compile-files source-directory build-directory files #:key (host %host-type) @@ -139,15 +161,18 @@ files are for HOST, a GNU triplet such as \"x86_64-linux-gnu\"." (define (build file) (with-mutex progress-lock (report-compilation file total completed)) - (with-fluids ((*current-warning-prefix* "")) - (with-target host - (lambda () - (let ((relative (relative-file source-directory file))) - (compile-file file - #:output-file (string-append build-directory "/" - (scm->go relative)) - #:opts (append warning-options - (optimization-options relative))))))) + + ;; Exit as soon as something goes wrong. + (exit-on-exception + (with-fluids ((*current-warning-prefix* "")) + (with-target host + (lambda () + (let ((relative (relative-file source-directory file))) + (compile-file file + #:output-file (string-append build-directory "/" + (scm->go relative)) + #:opts (append warning-options + (optimization-options relative)))))))) (with-mutex progress-lock (set! completed (+ 1 completed)))) diff --git a/guix/build/emacs-utils.scm b/guix/build/emacs-utils.scm index c1b00c7890..fdacd30dd6 100644 --- a/guix/build/emacs-utils.scm +++ b/guix/build/emacs-utils.scm @@ -60,7 +60,9 @@ (define* (emacs-byte-compile-directory dir) "Byte compile all files in DIR and its sub-directories." - (let ((expr `(byte-recompile-directory (file-name-as-directory ,dir) 0))) + (let ((expr `(progn + (setq byte-compile-debug t) ; for proper exit status + (byte-recompile-directory (file-name-as-directory ,dir) 0 1)))) (emacs-batch-eval expr))) (define-syntax emacs-substitute-sexps diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm index b4160fba1b..819688a913 100644 --- a/guix/build/profiles.scm +++ b/guix/build/profiles.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015, 2017, 2018 Ludovic Courtès <ludo@gnu.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +24,7 @@ #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (ice-9 pretty-print) + #:re-export (symlink-relative) ;for convenience #:export (ensure-writable-directory build-profile)) @@ -129,12 +130,15 @@ instead make DIRECTORY a \"real\" directory containing symlinks." (apply throw args)))))) (define* (build-profile output inputs - #:key manifest search-paths) - "Build a user profile from INPUTS in directory OUTPUT. Write MANIFEST, an -sexp, to OUTPUT/manifest. Create OUTPUT/etc/profile with Bash definitions for --all the variables listed in SEARCH-PATHS." + #:key manifest search-paths + (symlink symlink)) + "Build a user profile from INPUTS in directory OUTPUT, using SYMLINK to +create symlinks. Write MANIFEST, an sexp, to OUTPUT/manifest. Create +OUTPUT/etc/profile with Bash definitions for -all the variables listed in +SEARCH-PATHS." ;; Make the symlinks. (union-build output inputs + #:symlink symlink #:log-port (%make-void-port "w")) ;; Store meta-data. diff --git a/guix/build/r-build-system.scm b/guix/build/r-build-system.scm index 5e18939d22..4d8ac5b479 100644 --- a/guix/build/r-build-system.scm +++ b/guix/build/r-build-system.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2017 Ricardo Wurmus <rekado@elephly.net> +;;; Copyright © 2015, 2017, 2018 Ricardo Wurmus <rekado@elephly.net> ;;; ;;; This file is part of GNU Guix. ;;; @@ -24,6 +24,7 @@ #:use-module (ice-9 popen) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-35) #:export (%standard-phases r-build)) @@ -34,12 +35,19 @@ ;; Code: (define (invoke-r command params) - (zero? (apply system* "R" "CMD" command params))) + (apply invoke "R" "CMD" command params)) (define (pipe-to-r command params) (let ((port (apply open-pipe* OPEN_WRITE "R" params))) (display command port) - (zero? (status:exit-val (close-pipe port))))) + (let ((code (status:exit-val (close-pipe port)))) + (unless (zero? code) + (raise (condition ((@@ (guix build utils) &invoke-error) + (program "R") + (arguments (string-append params " " command)) + (exit-status (status:exit-val code)) + (term-signal (status:term-sig code)) + (stop-signal (status:stop-sig code))))))))) (define (generate-site-path inputs) (string-join (map (match-lambda @@ -68,13 +76,12 @@ (pkg-name (car (scandir libdir (negate (cut member <> '("." "..")))))) (testdir (string-append libdir pkg-name "/" test-target)) (site-path (string-append libdir ":" (generate-site-path inputs)))) - (if (and tests? (file-exists? testdir)) - (begin - (setenv "R_LIBS_SITE" site-path) - (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", " - "lib.loc = \"" libdir "\")") - '("--no-save" "--slave"))) - #t))) + (when (and tests? (file-exists? testdir)) + (setenv "R_LIBS_SITE" site-path) + (pipe-to-r (string-append "tools::testInstalledPackage(\"" pkg-name "\", " + "lib.loc = \"" libdir "\")") + '("--no-save" "--slave"))) + #t)) (define* (install #:key outputs inputs (configure-flags '()) #:allow-other-keys) diff --git a/guix/build/union.scm b/guix/build/union.scm index 1179f1234b..fff795c4d3 100644 --- a/guix/build/union.scm +++ b/guix/build/union.scm @@ -27,7 +27,10 @@ #:use-module (rnrs io ports) #:export (union-build - warn-about-collision)) + warn-about-collision + + relative-file-name + symlink-relative)) ;;; Commentary: ;;; @@ -78,14 +81,23 @@ identical, #f otherwise." (or (eof-object? n1) (loop)))))))))))))) +(define %harmless-collisions + ;; This is a list of files that are known to collide, but for which emitting + ;; a warning doesn't make sense. For example, "icon-theme.cache" is + ;; regenerated by a profile hook which shadows the file provided by + ;; individual packages, and "gschemas.compiled" is made available to + ;; applications via 'glib-or-gtk-build-system'. + '("icon-theme.cache" "gschemas.compiled")) + (define (warn-about-collision files) "Handle the collision among FILES by emitting a warning and choosing the first one of THEM." - (format (current-error-port) - "~%warning: collision encountered:~%~{ ~a~%~}" - files) (let ((file (first files))) - (format (current-error-port) "warning: choosing ~a~%" file) + (unless (member (basename file) %harmless-collisions) + (format (current-error-port) + "~%warning: collision encountered:~%~{ ~a~%~}" + files) + (format (current-error-port) "warning: choosing ~a~%" file)) file)) (define* (union-build output inputs @@ -174,4 +186,47 @@ returns #f, skip the faulty file altogether." (union-of-directories output (delete-duplicates inputs))) + +;;; +;;; Relative symlinks. +;;; + +(define %not-slash + (char-set-complement (char-set #\/))) + +(define (relative-file-name reference file) + "Given REFERENCE and FILE, both of which are absolute file names, return the +file name of FILE relative to REFERENCE. + + (relative-file-name \"/gnu/store/foo\" \"/gnu/store/bin/bar\") + => \"../bin/bar\" + +Note that this is from a purely lexical standpoint; conversely, \"..\" is +*not* resolved lexically on POSIX in the presence of symlinks." + (if (and (string-prefix? "/" file) (string-prefix? "/" reference)) + (let loop ((reference (string-tokenize reference %not-slash)) + (file (string-tokenize file %not-slash))) + (define (finish) + (string-join (append (make-list (length reference) "..") file) + "/")) + + (match reference + (() + (finish)) + ((head . tail) + (match file + (() + (finish)) + ((head* . tail*) + (if (string=? head head*) + (loop tail tail*) + (finish))))))) + file)) + +(define (symlink-relative old new) + "Assuming both OLD and NEW are absolute file names, make NEW a symlink to +OLD, but using a relative file name." + (symlink (relative-file-name (dirname new) old) + new)) + ;;; union.scm ends here |