diff options
Diffstat (limited to 'guix/build')
| -rw-r--r-- | guix/build/android-ndk-build-system.scm | 5 | ||||
| -rw-r--r-- | guix/build/chicken-build-system.scm | 1 | ||||
| -rw-r--r-- | guix/build/clojure-utils.scm | 1 | ||||
| -rw-r--r-- | guix/build/download-nar.scm | 74 | ||||
| -rw-r--r-- | guix/build/gnu-dist.scm | 5 | ||||
| -rw-r--r-- | guix/build/haskell-build-system.scm | 136 | ||||
| -rw-r--r-- | guix/build/linux-module-build-system.scm | 4 | ||||
| -rw-r--r-- | guix/build/svn.scm | 1 | ||||
| -rw-r--r-- | guix/build/syscalls.scm | 8 | ||||
| -rw-r--r-- | guix/build/tree-sitter-build-system.scm | 153 |
10 files changed, 253 insertions, 135 deletions
diff --git a/guix/build/android-ndk-build-system.scm b/guix/build/android-ndk-build-system.scm index 3c8f726d1d..0298292ac9 100644 --- a/guix/build/android-ndk-build-system.scm +++ b/guix/build/android-ndk-build-system.scm @@ -18,14 +18,9 @@ (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 diff --git a/guix/build/chicken-build-system.scm b/guix/build/chicken-build-system.scm index a669822dad..8f9f59cc25 100644 --- a/guix/build/chicken-build-system.scm +++ b/guix/build/chicken-build-system.scm @@ -18,7 +18,6 @@ (define-module (guix build chicken-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) - #:use-module (guix build union) #:use-module (guix build utils) #:use-module (ice-9 match) #:use-module (ice-9 ftw) diff --git a/guix/build/clojure-utils.scm b/guix/build/clojure-utils.scm index c5322141d3..57081d30f7 100644 --- a/guix/build/clojure-utils.scm +++ b/guix/build/clojure-utils.scm @@ -20,7 +20,6 @@ #:use-module (guix build utils) #:use-module (ice-9 ftw) #:use-module (ice-9 match) - #:use-module (ice-9 regex) #:use-module (srfi srfi-1) #:use-module (srfi srfi-8) #:use-module (srfi srfi-26) diff --git a/guix/build/download-nar.scm b/guix/build/download-nar.scm index 867f3c10bb..1b5b5503eb 100644 --- a/guix/build/download-nar.scm +++ b/guix/build/download-nar.scm @@ -18,9 +18,8 @@ (define-module (guix build download-nar) #:use-module (guix build download) - #:use-module (guix build utils) #:use-module ((guix serialization) #:hide (dump-port*)) - #:autoload (zlib) (call-with-gzip-input-port) + #:autoload (lzlib) (call-with-lzip-input-port) #:use-module (guix progress) #:use-module (web uri) #:use-module (srfi srfi-11) @@ -42,52 +41,21 @@ "Return the fallback nar URL for ITEM--e.g., \"/gnu/store/cabbag3…-foo-1.2-checkout\"." ;; Here we hard-code nar URLs without checking narinfos. That's probably OK - ;; though. Use berlin.guix.gnu.org instead of its ci.guix.gnu.org front end to - ;; avoid sending these requests to CDN providers without user consent. + ;; though. ;; TODO: Use HTTPS? The downside is the extra dependency. - (let ((bases '("http://berlin.guix.gnu.org")) + (let ((bases '("http://bordeaux.guix.gnu.org" + "http://ci.guix.gnu.org")) (item (basename item))) - (append (map (cut string-append <> "/nar/gzip/" item) bases) + (append (map (cut string-append <> "/nar/lzip/" item) bases) (map (cut string-append <> "/nar/" item) bases)))) -(define (restore-gzipped-nar port item size) - "Restore the gzipped nar read from PORT, of SIZE bytes (compressed), to +(define (restore-lzipped-nar port item size) + "Restore the lzipped nar read from PORT, of SIZE bytes (compressed), to ITEM." - ;; Since PORT is typically a non-file port (for instance because 'http-get' - ;; returns a delimited port), create a child process so we're back to a file - ;; port that can be passed to 'call-with-gzip-input-port'. - (match (pipe) - ((input . output) - (match (primitive-fork) - (0 - (dynamic-wind - (const #t) - (lambda () - (close-port output) - (close-port port) - (catch #t - (lambda () - (call-with-gzip-input-port input - (cut restore-file <> item))) - (lambda (key . args) - (print-exception (current-error-port) - (stack-ref (make-stack #t) 1) - key args) - (primitive-exit 1)))) - (lambda () - (primitive-exit 0)))) - (child - (close-port input) - (dump-port* port output - #:reporter (progress-reporter/file item size - #:abbreviation - store-path-abbreviation)) - (close-port output) - (newline) - (match (waitpid child) - ((_ . status) - (unless (zero? status) - (error "nar decompression failed" status))))))))) + (call-with-lzip-input-port port + (lambda (decompressed-port) + (restore-file decompressed-port + item)))) (define (download-nar item) "Download and extract the normalized archive for ITEM. Return #t on @@ -109,17 +77,25 @@ success, #f otherwise." (values #f #f))))) (if (not port) (loop rest) - (begin + (let* ((reporter (progress-reporter/file + url + size + (current-error-port) + #:abbreviation nar-uri-abbreviation)) + (port-with-progress + (progress-report-port reporter port + #:download-size size))) (if size (format #t "Downloading from ~a (~,2h MiB)...~%" url (/ size (expt 2 20.))) (format #t "Downloading from ~a...~%" url)) - (if (string-contains url "/gzip") - (restore-gzipped-nar port item size) + (if (string-contains url "/lzip") + (restore-lzipped-nar port-with-progress + item + size) (begin - ;; FIXME: Add progress report. - (restore-file port item) - (close-port port))) + (restore-file port-with-progress + item))) #t)))) (() #f)))) diff --git a/guix/build/gnu-dist.scm b/guix/build/gnu-dist.scm index fce1cd0759..cc48d3bdbf 100644 --- a/guix/build/gnu-dist.scm +++ b/guix/build/gnu-dist.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2013, 2015, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013, 2015, 2020, 2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> ;;; ;;; This file is part of GNU Guix. @@ -52,6 +52,7 @@ (delete 'strip) (replace 'install install-dist) (add-after 'build 'build-dist build) - (delete 'build))) + (delete 'build) + (delete 'install-license-files))) ;don't create 'OUT/share/doc' ;;; gnu-dist.scm ends here diff --git a/guix/build/haskell-build-system.scm b/guix/build/haskell-build-system.scm index ef6cb316ee..0e94cf59a5 100644 --- a/guix/build/haskell-build-system.scm +++ b/guix/build/haskell-build-system.scm @@ -5,6 +5,8 @@ ;;; Copyright © 2018, 2020 Ricardo Wurmus <rekado@elephly.net> ;;; Copyright © 2018 Alex Vong <alexvong1995@gmail.com> ;;; Copyright © 2021 John Kehayias <john.kehayias@protonmail.com> +;;; Copyright © 2022 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2022 Philip Munksgaard <philip@munksgaard.me> ;;; ;;; This file is part of GNU Guix. ;;; @@ -97,12 +99,14 @@ and parameters ~s~%" ,@(if tests? '("--enable-tests") '()) - ;; Build and link with shared libraries + ;; Build static and shared libraries. "--enable-shared" - "--enable-executable-dynamic" + "--enable-static" + ;; Link executables statically by default. + "--disable-executable-dynamic" "--ghc-option=-fPIC" - ,(string-append "--ghc-option=-optl=-Wl,-rpath=" (or lib out) - "/lib/$compiler/$pkg-$version") + ;; Ensure static libraries can be used with -Wl,--gc-sections for size. + "--ghc-option=-split-sections" ,@configure-flags))) ;; Cabal errors if GHC_PACKAGE_PATH is set during 'configure', so unset ;; and restore it. @@ -118,8 +122,7 @@ and parameters ~s~%" (setenv "CONFIG_SHELL" "sh")) (run-setuphs "configure" params) - (setenv "GHC_PACKAGE_PATH" ghc-path) - #t)) + (setenv "GHC_PACKAGE_PATH" ghc-path))) (define* (build #:key parallel-build? #:allow-other-keys) "Build a given Haskell package." @@ -130,18 +133,7 @@ and parameters ~s~%" (define* (install #:key outputs #:allow-other-keys) "Install a given Haskell package." - (run-setuphs "copy" '()) - (when (assoc-ref outputs "static") - (let ((static (assoc-ref outputs "static")) - (lib (or (assoc-ref outputs "lib") - (assoc-ref outputs "out")))) - (for-each (lambda (static-lib) - (let* ((subdir (string-drop static-lib (string-length lib))) - (new (string-append static subdir))) - (mkdir-p (dirname new)) - (rename-file static-lib new))) - (find-files lib "\\.a$")))) - #t) + (run-setuphs "copy" '())) (define* (setup-compiler #:key system inputs outputs #:allow-other-keys) "Setup the compiler environment." @@ -175,8 +167,7 @@ and parameters ~s~%" conf-files) (invoke "ghc-pkg" (string-append "--package-db=" %tmp-db-dir) - "recache") - #t)) + "recache"))) (define* (register #:key name system inputs outputs #:allow-other-keys) "Generate the compiler registration and binary package database files for a @@ -215,15 +206,54 @@ given Haskell package." (() #t) ;done ((id . tail) (if (not (vhash-assoc id seen)) - (let ((dep-conf (string-append src "/" id ".conf")) - (dep-conf* (string-append dest "/" id ".conf"))) - (when (not (file-exists? dep-conf)) + (let* ((dep-conf (string-append src "/" id ".conf")) + (dep-conf* (string-append dest "/" id ".conf")) + (dep-conf-exists? (file-exists? dep-conf)) + (dep-conf*-exists? (file-exists? dep-conf*)) + (next-tail (append lst (if dep-conf-exists? (conf-depends dep-conf) '())))) + (unless dep-conf*-exists? + (unless dep-conf-exists? (error (format #f "File ~a does not exist. This usually means the dependency ~a is missing. Was checking conf-file ~a." dep-conf id conf-file))) - (copy-file dep-conf dep-conf*) ;XXX: maybe symlink instead? - (loop (vhash-cons id #t seen) - (append lst (conf-depends dep-conf)))) + (copy-file dep-conf dep-conf*)) ;XXX: maybe symlink instead? + (loop (vhash-cons id #t seen) next-tail)) (loop seen tail)))))) + (define (install-config-file conf-file dest output:doc output:lib) + ;; Copy CONF-FILE to DEST removing reference to OUTPUT:DOC from + ;; OUTPUT:LIB and using install-transitive-deps. + (let* ((contents (call-with-input-file conf-file read-string)) + (id-rx (make-regexp "^id:[ \n\t]+([^ \t\n]+)$" regexp/newline)) + (config-file-name+id + (match:substring (first (list-matches id-rx contents)) 1))) + + (when (or + (and + (string? config-file-name+id) + (string-null? config-file-name+id)) + (not config-file-name+id)) + (error (format #f "The package id for ~a is empty. This is a bug." conf-file))) + + ;; Remove reference to "doc" output from "lib" (or "out") by rewriting the + ;; "haddock-interfaces" field and removing the optional "haddock-html" + ;; field in the generated .conf file. + (when output:doc + (substitute* conf-file + (("^haddock-html: .*") "\n") + (((format #f "^haddock-interfaces: ~a" output:doc)) + (string-append "haddock-interfaces: " output:lib))) + ;; Move the referenced file to the "lib" (or "out") output. + (match (find-files output:doc "\\.haddock$") + ((haddock-file . rest) + (let* ((subdir (string-drop haddock-file (string-length output:doc))) + (new (string-append output:lib subdir))) + (mkdir-p (dirname new)) + (rename-file haddock-file new))) + (_ #f))) + (install-transitive-deps conf-file %tmp-db-dir dest) + (rename-file conf-file + (string-append dest "/" + config-file-name+id ".conf")))) + (let* ((out (assoc-ref outputs "out")) (doc (assoc-ref outputs "doc")) (haskell (assoc-ref inputs "haskell")) @@ -233,7 +263,6 @@ given Haskell package." (config-dir (string-append lib "/ghc-" version "/" name ".conf.d")) - (id-rx (make-regexp "^id:[ \n\t]+([^ \t\n]+)$" regexp/newline)) (config-file (string-append out "/" name ".conf")) (params (list (string-append "--gen-pkg-config=" config-file)))) @@ -241,53 +270,24 @@ given Haskell package." ;; The conf file is created only when there is a library to register. (when (file-exists? config-file) (mkdir-p config-dir) - (let* ((contents (call-with-input-file config-file read-string)) - (config-file-name+id (match:substring (first (list-matches id-rx contents)) 1))) - - (when (or - (and - (string? config-file-name+id) - (string-null? config-file-name+id)) - (not config-file-name+id)) - (error (format #f "The package id for ~a is empty. This is a bug." config-file))) - - ;; Remove reference to "doc" output from "lib" (or "out") by rewriting the - ;; "haddock-interfaces" field and removing the optional "haddock-html" - ;; field in the generated .conf file. - (when doc - (substitute* config-file - (("^haddock-html: .*") "\n") - (((format #f "^haddock-interfaces: ~a" doc)) - (string-append "haddock-interfaces: " lib))) - ;; Move the referenced file to the "lib" (or "out") output. - (match (find-files doc "\\.haddock$") - ((haddock-file . rest) - (let* ((subdir (string-drop haddock-file (string-length doc))) - (new (string-append lib subdir))) - (mkdir-p (dirname new)) - (rename-file haddock-file new))) - (_ #f))) - (install-transitive-deps config-file %tmp-db-dir config-dir) - (rename-file config-file - (string-append config-dir "/" - config-file-name+id ".conf")) - (invoke "ghc-pkg" - (string-append "--package-db=" config-dir) - "recache"))) - #t)) + (if (file-is-directory? config-file) + (for-each (cut install-config-file <> config-dir doc lib) + (find-files config-file)) + (install-config-file config-file config-dir doc lib)) + (invoke "ghc-pkg" + (string-append "--package-db=" config-dir) + "recache")))) (define* (check #:key tests? test-target #:allow-other-keys) "Run the test suite of a given Haskell package." (if tests? (run-setuphs test-target '()) - (format #t "test suite not run~%")) - #t) + (format #t "test suite not run~%"))) (define* (haddock #:key outputs haddock? haddock-flags #:allow-other-keys) "Generate the Haddock documentation of a given Haskell package." (when haddock? - (run-setuphs "haddock" haddock-flags)) - #t) + (run-setuphs "haddock" haddock-flags))) (define* (patch-cabal-file #:key cabal-revision #:allow-other-keys) (when cabal-revision @@ -296,8 +296,7 @@ given Haskell package." ((original) (format #t "replacing ~s with ~s~%" original cabal-revision) (copy-file cabal-revision original)) - (_ (error "Could not find a Cabal file to patch.")))) - #t) + (_ (error "Could not find a Cabal file to patch."))))) (define* (generate-setuphs #:rest empty) "Generate a default Setup.hs if needed." @@ -307,8 +306,7 @@ given Haskell package." (with-output-to-file "Setup.hs" (lambda () (format #t "import Distribution.Simple~%") - (format #t "main = defaultMain~%")))) - #t) + (format #t "main = defaultMain~%"))))) (define %standard-phases (modify-phases gnu:%standard-phases diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index 18ccf7cd8b..b93c5eaf93 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -21,10 +21,6 @@ (define-module (guix build linux-module-build-system) #:use-module ((guix build gnu-build-system) #:prefix gnu:) #:use-module (guix build utils) - #:use-module (ice-9 ftw) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) #:export (%standard-phases linux-module-build)) diff --git a/guix/build/svn.scm b/guix/build/svn.scm index 44d77a968f..2d960cb364 100644 --- a/guix/build/svn.scm +++ b/guix/build/svn.scm @@ -22,7 +22,6 @@ (define-module (guix build svn) #:use-module (guix build utils) #:use-module (srfi srfi-34) - #:use-module (ice-9 format) #:export (svn-fetch)) ;;; Commentary: diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index 0358960ff5..df9b9f6ac7 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2014-2022 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2014-2023 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 David Thompson <davet@gnu.org> ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org> ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com> @@ -1400,7 +1400,8 @@ exception if it's already taken." thunk (lambda () (when port - (unlock-file port)))))) + (unlock-file port) + (delete-file file)))))) (define (call-with-file-lock/no-wait file thunk handler) (let ((port #f)) @@ -1428,7 +1429,8 @@ exception if it's already taken." thunk (lambda () (when port - (unlock-file port)))))) + (unlock-file port) + (delete-file file)))))) (define-syntax-rule (with-file-lock file exp ...) "Wait to acquire a lock on FILE and evaluate EXP in that context." diff --git a/guix/build/tree-sitter-build-system.scm b/guix/build/tree-sitter-build-system.scm new file mode 100644 index 0000000000..4106728bdf --- /dev/null +++ b/guix/build/tree-sitter-build-system.scm @@ -0,0 +1,153 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Pierre Langlois <pierre.langlois@gmx.com> +;;; +;;; 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 tree-sitter-build-system) + #:use-module ((guix build node-build-system) #:prefix node:) + #:use-module (guix build json) + #:use-module (guix build utils) + #:use-module (ice-9 match) + #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) + #:export (%standard-phases + tree-sitter-build)) + +;; Commentary: +;; +;; Build procedures for tree-sitter grammar packages. This is the +;; builder-side code, which builds on top of the node build-system. +;; +;; Tree-sitter grammars are written in JavaScript and compiled to a native +;; shared object. The `tree-sitter generate' command invokes `node' in order +;; to evaluate the grammar.js into a grammar.json file, which is then +;; translated into C code. We then compile the C code ourselves. Packages +;; also sometimes add extra manually written C/C++ code. +;; +;; In order to support grammars depending on each other, such as C and C++, +;; JavaScript and TypeScript, this build-system installs the source of the +;; node module in a dedicated "js" output. +;; +;; Code: + +(define* (patch-dependencies #:key inputs #:allow-other-keys) + "Rewrite dependencies in 'package.json'. We remove all runtime dependencies +and replace development dependencies with tree-sitter grammar node modules." + + (define (rewrite package.json) + (map (match-lambda + (("dependencies" @ . _) + '("dependencies" @)) + (("devDependencies" @ . _) + `("devDependencies" @ + ,@(filter-map (match-lambda + ((key . directory) + (let ((node-module + (string-append directory + "/lib/node_modules/" + key))) + (and (directory-exists? node-module) + `(,key . ,node-module))))) + (alist-delete "node" inputs)))) + (other other)) + package.json)) + + (node:with-atomic-json-file-replacement "package.json" + (match-lambda + (('@ . package.json) + (cons '@ (rewrite package.json)))))) + +;; FIXME: The node build-system's configure phase does not support +;; cross-compiling so we re-define it. +(define* (configure #:key native-inputs inputs #:allow-other-keys) + (invoke (search-input-file (or native-inputs inputs) "/bin/npm") + "--offline" "--ignore-scripts" "install")) + +(define* (build #:key grammar-directories #:allow-other-keys) + (for-each (lambda (dir) + (with-directory-excursion dir + ;; Avoid generating binding code for other languages, we do + ;; not support this use-case yet and it relies on running + ;; `node-gyp' to build native addons. + (invoke "tree-sitter" "generate" "--no-bindings"))) + grammar-directories)) + +(define* (check #:key grammar-directories tests? #:allow-other-keys) + (when tests? + (for-each (lambda (dir) + (with-directory-excursion dir + (invoke "tree-sitter" "test"))) + grammar-directories))) + +(define* (install #:key target grammar-directories outputs #:allow-other-keys) + (let ((lib (string-append (assoc-ref outputs "out") + "/lib/tree-sitter"))) + (mkdir-p lib) + (define (compile-language dir) + (with-directory-excursion dir + (let ((lang (assoc-ref (call-with-input-file "src/grammar.json" + read-json) + "name")) + (source-file (lambda (path) + (if (file-exists? path) + path + #f)))) + (apply invoke + `(,(if target + (string-append target "-g++") + "g++") + "-shared" + "-fPIC" + "-fno-exceptions" + "-O2" + "-g" + "-o" ,(string-append lib "/libtree-sitter-" lang ".so") + ;; An additional `scanner.{c,cc}' file is sometimes + ;; provided. + ,@(cond + ((source-file "src/scanner.c") + => (lambda (file) (list "-xc" "-std=c99" file))) + ((source-file "src/scanner.cc") + => (lambda (file) (list file))) + (else '())) + "-xc" "src/parser.c"))))) + (for-each compile-language grammar-directories))) + +(define* (install-js #:key native-inputs inputs outputs #:allow-other-keys) + (invoke (search-input-file (or native-inputs inputs) "/bin/npm") + "--prefix" (assoc-ref outputs "js") + "--global" + "--offline" + "--loglevel" "info" + "--production" + ;; Skip scripts to prevent building bindings via GYP. + "--ignore-scripts" + "install" "../package.tgz")) + +(define %standard-phases + (modify-phases node:%standard-phases + (replace 'patch-dependencies patch-dependencies) + (replace 'configure configure) + (replace 'build build) + (replace 'check check) + (replace 'install install) + (add-after 'install 'install-js install-js))) + +(define* (tree-sitter-build #:key inputs (phases %standard-phases) + #:allow-other-keys #:rest args) + (apply node:node-build #:inputs inputs #:phases phases args)) + +;;; tree-sitter-build-system.scm ends here |