From 1cf866c863e38bc2a61077e38f416fe3d310e340 Mon Sep 17 00:00:00 2001 From: zimoun Date: Wed, 1 Sep 2021 11:57:55 +0200 Subject: import: Add hint for importer typo. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/import.scm (define-command): Add hint. Signed-off-by: Ludovic Courtès --- guix/scripts/import.scm | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index b369a362d0..11e94769bb 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2014 David Thompson ;;; Copyright © 2018 Kyle Meyer ;;; Copyright © 2019 Ricardo Wurmus +;;; Copyright © 2021 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -130,4 +131,9 @@ Run IMPORTER with ARGS.\n")) expressions)) (x (leave (G_ "'~a' import failed~%") importer)))) - (leave (G_ "~a: invalid importer~%") importer))))) + (let ((hint (string-closest importer importers #:threshold 3))) + (report-error (G_ "~a: invalid importer~%") importer) + (when hint + (display-hint + (format #f (G_ "Did you mean @code{~a}?~%") hint))) + (exit 1)))))) -- cgit v1.2.3 From b8b56badd3a19a898857cb9a90150536233ba0b2 Mon Sep 17 00:00:00 2001 From: zimoun Date: Wed, 1 Sep 2021 11:57:56 +0200 Subject: system: Add hint for action typo. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/scripts/system.scm (actions): New variable. (define-command): Add hint for action typo. Signed-off-by: Ludovic Courtès --- guix/scripts/system.scm | 31 ++++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index 83bbefd3dc..65eb98e4b2 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -9,6 +9,7 @@ ;;; Copyright © 2020 Julien Lepiller ;;; Copyright © 2020 Efraim Flashner ;;; Copyright © 2021 Brice Waegeneire +;;; Copyright © 2021 Simon Tournier ;;; ;;; This file is part of GNU Guix. ;;; @@ -1152,6 +1153,13 @@ Some ACTIONS support additional ARGS.\n")) ;;; Entry point. ;;; +(define actions '("build" "container" "vm" "vm-image" "image" "disk-image" + "reconfigure" "init" + "extension-graph" "shepherd-graph" + "list-generations" "describe" + "delete-generations" "roll-back" + "switch-generation" "search" "docker-image")) + (define (process-action action args opts) "Process ACTION, a sub-command, with the arguments are listed in ARGS. ACTION must be one of the sub-commands that takes an operating system @@ -1335,17 +1343,18 @@ argument list and OPTS is the option alist." (define (parse-sub-command arg result) ;; Parse sub-command ARG and augment RESULT accordingly. - (if (assoc-ref result 'action) - (alist-cons 'argument arg result) - (let ((action (string->symbol arg))) - (case action - ((build container vm vm-image image disk-image reconfigure init - extension-graph shepherd-graph - list-generations describe - delete-generations roll-back - switch-generation search docker-image) - (alist-cons 'action action result)) - (else (leave (G_ "~a: unknown action~%") action)))))) + (cond ((assoc-ref result 'action) + (alist-cons 'argument arg result)) + ((member arg actions) + (let ((action (string->symbol arg))) + (alist-cons 'action action result))) + (else + (let ((hint (string-closest arg actions #:threshold 3))) + (report-error (G_ "~a: unknown action~%") arg) + (when hint + (display-hint + (format #f (G_ "Did you mean @code{~a}?~%") hint))) + (exit 1))))) (define (match-pair car) ;; Return a procedure that matches a pair with CAR. -- cgit v1.2.3 From af4fa7c00cae47552486c28d5559c53e058b597f Mon Sep 17 00:00:00 2001 From: Xinglu Chen Date: Tue, 31 Aug 2021 20:17:52 +0200 Subject: import: elpa: Support NonGNU ELPA. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/elpa.scm (elpa-url): Add NonGNU ELPA URL. * doc/guix.texi (Invoking guix import): Document it. Signed-off-by: Ludovic Courtès --- doc/guix.texi | 4 ++++ guix/import/elpa.scm | 2 ++ 2 files changed, 6 insertions(+) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 36a0c7f5ec..679f6b4369 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -11605,6 +11605,10 @@ contained in the GnuPG keyring at @code{emacs} package (@pxref{Package Installation, ELPA package signatures,, emacs, The GNU Emacs Manual}). +@item +@uref{https://elpa.nongnu.org/nongnu/, NonGNU}, selected by the +@code{nongnu} identifier. + @item @uref{https://stable.melpa.org/packages, MELPA-Stable}, selected by the @code{melpa-stable} identifier. diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index c0dc5acf51..fb59acc9e3 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2018 Oleg Pykhalov ;;; Copyright © 2020 Martin Becze ;;; Copyright © 2020 Ricardo Wurmus +;;; Copyright © 2021 Xinglu Chen ;;; ;;; This file is part of GNU Guix. ;;; @@ -80,6 +81,7 @@ NAMES (strings)." (let ((elpa-archives '((gnu . "https://elpa.gnu.org/packages") (gnu/http . "http://elpa.gnu.org/packages") ;for testing + (nongnu . "https://elpa.nongnu.org/nongnu") (melpa-stable . "https://stable.melpa.org/packages") (melpa . "https://melpa.org/packages")))) (assq-ref elpa-archives repo))) -- cgit v1.2.3 From e8a67f0fc4f7274d2447ac247df60b69d98e1b4e Mon Sep 17 00:00:00 2001 From: Sarah Morgensen Date: Mon, 30 Aug 2021 19:05:19 -0700 Subject: import: go: Fix import when import path redirects. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/go.scm (fetch-module-meta-data): If no meta entries have a matching import prefix, return the first entry instead of #f. Signed-off-by: Ludovic Courtès --- guix/import/go.scm | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/import/go.scm b/guix/import/go.scm index 4755571209..c6ecdbaffd 100644 --- a/guix/import/go.scm +++ b/guix/import/go.scm @@ -485,9 +485,12 @@ build a package." (match (select (html->sxml meta-data #:strict? #t)) (() #f) ;nothing selected ((('content content-text) ..1) - (find (lambda (meta) - (string-prefix? (module-meta-import-prefix meta) module-path)) - (map go-import->module-meta content-text)))))) + (or + (find (lambda (meta) + (string-prefix? (module-meta-import-prefix meta) module-path)) + (map go-import->module-meta content-text)) + ;; Fallback to the first meta if no import prefixes match. + (go-import->module-meta (first content-text))))))) (define (module-meta-data-repo-url meta-data goproxy) "Return the URL where the fetcher which will be used can download the -- cgit v1.2.3 From f8f94cc5446753b37ab3ddd23e21919efd006769 Mon Sep 17 00:00:00 2001 From: pukkamustard Date: Tue, 7 Sep 2021 13:41:12 +0200 Subject: guix: dune-build-system: Put dune into a reproducible release mode. * guix/build/dune-build-system.scm (build,check): Replace the profile parameter with the appropriate release flags. * guix/build-system/dune.scm: Remove the profile parameter. * doc/guix.texi: Remove paragraph on profile parameter. Signed-off-by: Julien Lepiller --- doc/guix.texi | 5 ----- guix/build-system/dune.scm | 19 ++++++++++++++++--- guix/build/dune-build-system.scm | 15 +++++++++------ 3 files changed, 25 insertions(+), 14 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 679f6b4369..29246ad4e5 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7735,11 +7735,6 @@ is useful when a package contains multiple packages and you want to build only one of them. This is equivalent to passing the @code{-p} argument to @code{dune}. -The @code{#:profile} parameter can be passed to specify the -@uref{https://dune.readthedocs.io/en/stable/dune-files.html#profile, -dune build profile}. This is equivalent to passing the @code{--profile} -argument to @code{dune}. Its default value is @code{"release"}. - @end defvr @defvr {Scheme Variable} go-build-system diff --git a/guix/build-system/dune.scm b/guix/build-system/dune.scm index 1a64cf9b75..5b33ef6841 100644 --- a/guix/build-system/dune.scm +++ b/guix/build-system/dune.scm @@ -60,6 +60,17 @@ #:allow-other-keys #:rest arguments) "Return a bag for NAME." + + ;; Flags that put dune into reproducible build mode. + (define dune-release-flags + (if (version>=? (package-version dune) "2.5.0") + ;; For dune >= 2.5.0 this is just --release. + ''("--release") + ;; --release does not exist before 2.5.0. Replace with flags compatible + ;; with our old ocaml4.07-dune (1.11.3) + ''("--root" "." "--ignore-promoted-rules" "--no-config" + "--profile" "release"))) + (define private-keywords '(#:source #:target #:dune #:findlib #:ocaml #:inputs #:native-inputs)) @@ -79,7 +90,9 @@ (build-inputs `(("dune" ,dune) ,@(bag-build-inputs base))) (build dune-build) - (arguments (strip-keyword-arguments private-keywords arguments)))))) + (arguments (append + `(#:dune-release-flags ,dune-release-flags) + (strip-keyword-arguments private-keywords arguments))))))) (define* (dune-build store name inputs #:key (guile #f) @@ -89,7 +102,7 @@ (out-of-source? #t) (jbuild? #f) (package #f) - (profile "release") + (dune-release-flags ''()) (tests? #t) (test-flags ''()) (test-target "test") @@ -129,7 +142,7 @@ provides a 'setup.ml' file as its build system." #:out-of-source? ,out-of-source? #:jbuild? ,jbuild? #:package ,package - #:profile ,profile + #:dune-release-flags ,dune-release-flags #:tests? ,tests? #:test-target ,test-target #:install-target ,install-target diff --git a/guix/build/dune-build-system.scm b/guix/build/dune-build-system.scm index 6a0c2593ac..e9ccc71057 100644 --- a/guix/build/dune-build-system.scm +++ b/guix/build/dune-build-system.scm @@ -32,23 +32,26 @@ ;; Code: (define* (build #:key (build-flags '()) (jbuild? #f) - (use-make? #f) (package #f) - (profile "release") #:allow-other-keys) + (use-make? #f) (package #f) (dune-release-flags '()) + #:allow-other-keys) "Build the given package." (let ((program (if jbuild? "jbuilder" "dune"))) (apply invoke program "build" "@install" - (append (if package (list "-p" package) '()) - `("--profile" ,profile) + (append (if package (list "-p" package) + dune-release-flags) build-flags))) #t) (define* (check #:key (test-flags '()) (test-target "test") tests? - (jbuild? #f) (package #f) #:allow-other-keys) + (jbuild? #f) (package #f) (dune-release-flags '()) + #:allow-other-keys) "Test the given package." (when tests? (let ((program (if jbuild? "jbuilder" "dune"))) (apply invoke program "runtest" test-target - (append (if package (list "-p" package) '()) test-flags)))) + (append (if package (list "-p" package) + dune-release-flags) + test-flags)))) #t) (define* (install #:key outputs (install-target "install") (jbuild? #f) -- cgit v1.2.3 From 1dc3825e9940de44c1f170add7bd26d61830ce34 Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Mon, 6 Sep 2021 00:21:51 +0200 Subject: git: 'resolve-reference' handles 'git describe'-style commit IDs. * guix/git.scm (resolve-reference): Rewrite tag-or-commit case to recognize 'git describe' style identifiers and resolve them as commits. * doc/guix.texi (origin Reference): Mention it. --- doc/guix.texi | 9 +++++---- guix/git.scm | 33 ++++++++++++++++++++++++--------- 2 files changed, 29 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 29246ad4e5..f88967b593 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -47,7 +47,7 @@ Copyright @copyright{} 2017, 2018 Carlo Zancanaro@* Copyright @copyright{} 2017 Thomas Danckaert@* Copyright @copyright{} 2017 humanitiesNerd@* Copyright @copyright{} 2017, 2021 Christine Lemmer-Webber@* -Copyright @copyright{} 2017, 2018, 2019, 2020 Marius Bakke@* +Copyright @copyright{} 2017, 2018, 2019, 2020, 2021 Marius Bakke@* Copyright @copyright{} 2017, 2019, 2020 Hartmut Goebel@* Copyright @copyright{} 2017, 2019, 2020, 2021 Maxim Cournoyer@* Copyright @copyright{} 2017, 2018, 2019, 2020, 2021 Tobias Geerinckx-Rice@* @@ -7010,9 +7010,10 @@ retrieve. The URL of the Git repository to clone. @item @code{commit} -This string denotes either the commit to fetch (a hexadecimal string, -either the full SHA1 commit or a ``short'' commit string; the latter is -not recommended) or the tag to fetch. +This string denotes either the commit to fetch (a hexadecimal string), +or the tag to fetch. You can also use a ``short'' commit ID or a +@command{git describe} style identifier such as +@code{v1.0.1-10-g58d7909c97}. @item @code{recursive?} (default: @code{#f}) This Boolean indicates whether to recursively fetch Git sub-modules. diff --git a/guix/git.scm b/guix/git.scm index 9c6f326c36..621de0e925 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2017, 2020 Mathieu Othacehe ;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès ;;; Copyright © 2021 Kyle Meyer +;;; Copyright © 2021 Marius Bakke ;;; ;;; This file is part of GNU Guix. ;;; @@ -223,15 +224,29 @@ corresponding Git object." (object-lookup-prefix repository (string->oid commit) len) (object-lookup repository (string->oid commit))))) (('tag-or-commit . str) - (if (or (> (string-length str) 40) - (not (string-every char-set:hex-digit str))) - (resolve `(tag . ,str)) ;definitely a tag - (catch 'git-error - (lambda () - (resolve `(tag . ,str))) - (lambda _ - ;; There's no such tag, so it must be a commit ID. - (resolve `(commit . ,str)))))) + (cond ((and (string-contains str "-g") + (match (string-split str #\-) + ((version ... revision g+commit) + (if (and (> (string-length g+commit) 4) + (string-every char-set:digit revision) + (string-every char-set:hex-digit + (string-drop g+commit 1))) + (string-drop g+commit 1) + #f)) + (_ #f))) + ;; Looks like a 'git describe' style ID, like + ;; v1.3.0-7-gaa34d4d28d. + => (lambda (commit) (resolve `(commit . ,commit)))) + ((or (> (string-length str) 40) + (not (string-every char-set:hex-digit str))) + (resolve `(tag . ,str))) ;definitely a tag + (else + (catch 'git-error + (lambda () + (resolve `(tag . ,str))) + (lambda _ + ;; There's no such tag, so it must be a commit ID. + (resolve `(commit . ,str))))))) (('tag . tag) (let ((oid (reference-name->oid repository (string-append "refs/tags/" tag)))) -- cgit v1.2.3 From 16ef7b4938b14e68f8ca7504c9614f84530572ed Mon Sep 17 00:00:00 2001 From: Marius Bakke Date: Sat, 4 Sep 2021 19:07:52 +0200 Subject: transformations: Git tags and 'git describe' style IDs are used as version. * guix/transformations.scm (commit->version-string): New procedure. Use git tags and 'git describe' style identifiers directly. (transform-package-source-commit): Adjust accordingly. * tests/transformations.scm ("options->transformation, with-commit, version transformation"): New test. * doc/guix.texi (Package Transformation Options): Mention the 'git describe' style. --- doc/guix.texi | 3 ++- guix/git.scm | 4 ++-- guix/transformations.scm | 30 +++++++++++++++++++++--------- tests/transformations.scm | 21 +++++++++++++++++++++ 4 files changed, 46 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index f88967b593..220499503d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -10652,7 +10652,8 @@ guix build --with-branch=guile-sqlite3=master cuirass @item --with-commit=@var{package}=@var{commit} This is similar to @option{--with-branch}, except that it builds from @var{commit} rather than the tip of a branch. @var{commit} must be a valid -Git commit SHA1 identifier or a tag. +Git commit SHA1 identifier, a tag, or a @command{git describe} style +identifier such as @code{1.0-3-gabc123}. @item --with-patch=@var{package}=@var{file} Add @var{file} to the list of patches applied to @var{package}, where diff --git a/guix/git.scm b/guix/git.scm index 621de0e925..acc48fd12f 100644 --- a/guix/git.scm +++ b/guix/git.scm @@ -231,11 +231,11 @@ corresponding Git object." (string-every char-set:digit revision) (string-every char-set:hex-digit (string-drop g+commit 1))) + ;; Looks like a 'git describe' style ID, like + ;; v1.3.0-7-gaa34d4d28d. (string-drop g+commit 1) #f)) (_ #f))) - ;; Looks like a 'git describe' style ID, like - ;; v1.3.0-7-gaa34d4d28d. => (lambda (commit) (resolve `(commit . ,commit)))) ((or (> (string-length str) 40) (not (string-every char-set:hex-digit str))) diff --git a/guix/transformations.scm b/guix/transformations.scm index 5122baa403..5ae1977cb2 100644 --- a/guix/transformations.scm +++ b/guix/transformations.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès +;;; Copyright © 2021 Marius Bakke ;;; ;;; This file is part of GNU Guix. ;;; @@ -270,6 +271,25 @@ strings like \"guile-next=stable-3.0\" meaning that packages are built using (rewrite obj) obj)))) +(define (commit->version-string commit) + "Return a string suitable for use in the 'version' field of a package based +on the given COMMIT." + (cond ((and (> (string-length commit) 1) + (string-prefix? "v" commit) + (char-set-contains? char-set:digit + (string-ref commit 1))) + ;; Probably a tag like "v1.0" or a 'git describe' identifier. + (string-drop commit 1)) + ((not (string-every char-set:hex-digit commit)) + ;; Pass through tags and 'git describe' style IDs directly. + commit) + (else + (string-append "git." + (if (< (string-length commit) 7) + commit + (string-take commit 7)))))) + + (define (transform-package-source-commit replacement-specs) "Return a procedure that, when passed a package, replaces its direct dependencies according to REPLACEMENT-SPECS. REPLACEMENT-SPECS is a list of @@ -278,15 +298,7 @@ strings like \"guile-next=cabba9e\" meaning that packages are built using (define (replace old url commit) (package (inherit old) - (version (if (and (> (string-length commit) 1) - (string-prefix? "v" commit) - (char-set-contains? char-set:digit - (string-ref commit 1))) - (string-drop commit 1) ;looks like a tag like "v1.0" - (string-append "git." - (if (< (string-length commit) 7) - commit - (string-take commit 7))))) + (version (commit->version-string commit)) (source (git-checkout (url url) (commit commit) (recursive? #t))))) diff --git a/tests/transformations.scm b/tests/transformations.scm index 3417c994ec..09839dc1c5 100644 --- a/tests/transformations.scm +++ b/tests/transformations.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017, 2019, 2020, 2021 Ludovic Courtès +;;; Copyright © 2021 Marius Bakke ;;; ;;; This file is part of GNU Guix. ;;; @@ -235,6 +236,26 @@ (string=? (package-name dep2) "chbouib") (package-source dep2)))))))) +(test-equal "options->transformation, with-commit, version transformation" + '("1.0" "1.0-rc1-2-gabc123" "git.abc123") + (map (lambda (commit) + (let* ((p (dummy-package "guix.scm" + (inputs `(("foo" ,(dummy-package "chbouib" + (source (origin + (method git-fetch) + (uri (git-reference + (url "https://example.org") + (commit "cabba9e"))) + (sha256 #f))))))))) + (t (options->transformation + `((with-commit . ,(string-append "chbouib=" commit)))))) + (let ((new (t p))) + (and (not (eq? new p)) + (match (package-inputs new) + ((("foo" dep1)) + (package-version dep1))))))) + '("v1.0" "1.0-rc1-2-gabc123" "abc123"))) + (test-equal "options->transformation, with-git-url" (let ((source (git-checkout (url "https://example.org") (recursive? #t)))) -- cgit v1.2.3 From fb32a38db1d3a6d9bc970e14df5be95e59a8ab02 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 9 Sep 2021 11:18:06 +0200 Subject: swh: Adjust to latest API changes. Fixes uses of 'swh-download' as reported at . Reported by zimoun. * guix/swh.scm ()[object-id, object-type]: Remove. These two fields are no longer provided in JSON replies. [swhid]: New field. --- guix/swh.scm | 8 +++----- 1 file changed, 3 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index 922d781a7b..76234b4358 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -104,10 +104,9 @@ vault-reply? vault-reply-id vault-reply-fetch-url - vault-reply-object-id - vault-reply-object-type vault-reply-progress-message vault-reply-status + vault-reply-swhid query-vault request-cooking vault-fetch @@ -391,10 +390,9 @@ FALSE-IF-404? is true, return #f upon 404 responses." json->vault-reply (id vault-reply-id) (fetch-url vault-reply-fetch-url "fetch_url") - (object-id vault-reply-object-id "obj_id") - (object-type vault-reply-object-type "obj_type" string->symbol) (progress-message vault-reply-progress-message "progress_message") - (status vault-reply-status "status" string->symbol)) + (status vault-reply-status "status" string->symbol) + (swhid vault-reply-swhid)) ;;; -- cgit v1.2.3 From a87d8c912d64382d8d7489c156249bc2b2638df0 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Mon, 6 Sep 2021 00:46:17 +0200 Subject: base16: Reduce GC pressure in bytevector->base16-string. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit This makes bytevector->base16-string two times faster. * guix/base16.scm (bytevector->base16-string): Use utf8->string and iteration instead of string-concatenate and named let. Signed-off-by: Ludovic Courtès --- guix/base16.scm | 44 +++++++++++++++++++++++--------------------- 1 file changed, 23 insertions(+), 21 deletions(-) (limited to 'guix') diff --git a/guix/base16.scm b/guix/base16.scm index 6c15a9f588..9ac964dff0 100644 --- a/guix/base16.scm +++ b/guix/base16.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2012, 2014, 2017 Ludovic Courtès +;;; Copyright © 2021 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -32,27 +33,28 @@ (define (bytevector->base16-string bv) "Return the hexadecimal representation of BV's contents." - (define len - (bytevector-length bv)) - - (let-syntax ((base16-chars (lambda (s) - (syntax-case s () - (_ - (let ((v (list->vector - (unfold (cut > <> 255) - (lambda (n) - (format #f "~2,'0x" n)) - 1+ - 0)))) - v)))))) - (define chars base16-chars) - (let loop ((i len) - (r '())) - (if (zero? i) - (string-concatenate r) - (let ((i (- i 1))) - (loop i - (cons (vector-ref chars (bytevector-u8-ref bv i)) r))))))) + (define len (bytevector-length bv)) + (define utf8 (make-bytevector (* len 2))) + (let-syntax ((base16-octet-pairs + (lambda (s) + (syntax-case s () + (_ + (string->utf8 + (string-concatenate + (unfold (cut > <> 255) + (lambda (n) + (format #f "~2,'0x" n)) + 1+ + 0)))))))) + (define octet-pairs base16-octet-pairs) + (let loop ((i 0)) + (when (< i len) + (bytevector-u16-native-set! + utf8 (* 2 i) + (bytevector-u16-native-ref octet-pairs + (* 2 (bytevector-u8-ref bv i)))) + (loop (+ i 1)))) + (utf8->string utf8))) (define base16-string->bytevector (let ((chars->value (fold (lambda (i r) -- cgit v1.2.3 From cb06f7c61e4b8393abf38f1f5891e03c33d53b9b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 9 Sep 2021 23:22:10 +0200 Subject: base32: Provide an open-coded 'bit-field'. This improves the throughput of 'bytevector->base32-string' a bit. * guix/base32.scm (bit-field): New macro. --- guix/base32.scm | 15 ++++++++++++++- 1 file changed, 14 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/base32.scm b/guix/base32.scm index 49f191ba26..d6c8a02243 100644 --- a/guix/base32.scm +++ b/guix/base32.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2015, 2017 Ludovic Courtès +;;; Copyright © 2012, 2015, 2017, 2021 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -42,6 +42,19 @@ ;;; ;;; Code: +(define-syntax bit-field + (lambda (s) + ;; This inline version of 'bit-field' assumes that START and END are + ;; literals and pre-computes the mask. In an ideal world, using 'define' + ;; or 'define-inlinable' would be enough, but as of 3.0.7, peval doesn't + ;; expand calls to 'expt' (and 'bit-field' is a subr.) + (syntax-case s () + ((_ n start end) + (let* ((s (syntax->datum #'start)) + (e (syntax->datum #'end)) + (mask (- (expt 2 (- e s)) 1))) + #`(logand (ash n (- start)) #,mask)))))) + (define bytevector-quintet-ref (let* ((ref bytevector-u8-ref) (ref+ (lambda (bv offset) -- cgit v1.2.3 From 163d6385fd4f06860726876086d92d0e81dc6442 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 10 Sep 2021 14:59:53 +0200 Subject: lint: archival: Warn about non-origin sources. * guix/lint.scm (check-archival): Warn about non-origin sources. --- guix/lint.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/lint.scm b/guix/lint.scm index ffd3f7007e..527fda165a 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -1562,7 +1562,11 @@ Disarchive entry refers to non-existent SWH directory '~a'") #:field 'source))))))) ((? content?) '()))) - '())))) + '())) + (_ + (list (make-warning package + (G_ "unsupported source type") + #:field 'source))))) (match-lambda* (('swh-error url method response) (response->warning url method response)) -- cgit v1.2.3 From ff613c2b68aac539262822490448e637d8f315ba Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 10 Sep 2021 11:42:25 +0200 Subject: swh: Adjust to new vault API. Previously the path to query the vault or request cooking of a directory was /api/1/vault/directory/ID. It is now deprecated in favor if /api/1/vault/flat/SWHID. This commit adjusts code accordingly and also prepares for 'git-bare' support. * guix/swh.scm (vault-url): New procedure. (query-vault, request-cooking): Make 'kind' optional, and add #:archive-type. Use 'vault-url'. (vault-fetch): Make 'kind' optional and add #:archive-type. Adjust 'query-vault' and 'request-cooking' calls accordingly. --- guix/swh.scm | 76 +++++++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 50 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index 76234b4358..3d5d2a410a 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -538,35 +538,57 @@ directory entries; if it has type 'file, return its object." (path "/api/1/origin/save" type "url" url) json->save-reply) -(define-query (query-vault id kind) - "Ask the availability of object ID and KIND to the vault, where KIND is -'directory or 'revision. Return #f if it could not be found, or a - on success." - ;; - ;; There's a single format supported for directories and revisions and for - ;; now, the "/format" bit of the URL *must* be omitted. - (path "/api/1/vault" (symbol->string kind) id) - json->vault-reply) - -(define (request-cooking id kind) - "Request the cooking of object ID and KIND (one of 'directory or 'revision) -to the vault. Return a ." - (call (swh-url "/api/1/vault" (symbol->string kind) id) +(define* (vault-url id kind #:optional (archive-type 'flat)) + "Return the vault query/cooking URL for ID and KIND. Normally, ID is an +SWHID and KIND is #f; the deprecated convention is to set ID to a raw +directory or revision ID and KIND to 'revision or 'directory." + ;; Note: /api/1/vault/directory/ID was deprecated in favor of + ;; /api/1/vault/flat/SWHID; this procedure "converts" automatically. + (let ((id (match kind + ('directory (string-append "swh:1:dir:" id)) + ('revision (string-append "swh:1:rev:" id)) + (#f id)))) + (swh-url "/api/1/vault" (symbol->string archive-type) id))) + +(define* (query-vault id #:optional kind #:key (archive-type 'flat)) + "Ask the availability of object ID (an SWHID) to the vault. Return #f if it +could not be found, or a on success. ARCHIVE-TYPE can be 'flat +for a tarball containing a directory, or 'git-bare for a tarball containing a +bare Git repository corresponding to a revision. + +Passing KIND (one of 'directory or 'revision) together with a raw revision or +directory identifier is deprecated." + (call (vault-url id kind archive-type) + json->vault-reply)) + +(define* (request-cooking id #:optional kind #:key (archive-type 'flat)) + "Request the cooking of object ID, an SWHID. Return a . +ARCHIVE-TYPE can be 'flat for a tarball containing a directory, or 'git-bare +for a tarball containing a bare Git repository corresponding to a revision. + +Passing KIND (one of 'directory or 'revision) together with a raw revision or +directory identifier is deprecated." + (call (vault-url id kind archive-type) json->vault-reply http-post*)) -(define* (vault-fetch id kind - #:key (log-port (current-error-port))) - "Return an input port from which a bundle of the object with the given ID -and KIND (one of 'directory or 'revision) can be retrieved, or #f if the -object could not be found. - -For a directory, the returned stream is a gzip-compressed tarball. For a -revision, it is a gzip-compressed stream for 'git fast-import'." - (let loop ((reply (query-vault id kind))) +(define* (vault-fetch id + #:optional kind + #:key + (archive-type 'flat) + (log-port (current-error-port))) + "Return an input port from which a bundle of the object with the given ID, +an SWHID, or #f if the object could not be found. + +ARCHIVE-TYPE can be 'flat for a tarball containing a directory, or 'git-bare +for a tarball containing a bare Git repository corresponding to a revision." + (let loop ((reply (query-vault id kind + #:archive-type archive-type))) (match reply (#f - (and=> (request-cooking id kind) loop)) + (and=> (request-cooking id kind + #:archive-type archive-type) + loop)) (_ (match (vault-reply-status reply) ('done @@ -586,7 +608,8 @@ revision, it is a gzip-compressed stream for 'git fast-import'." (format log-port "SWH vault: failure: ~a~%" (vault-reply-progress-message reply)) (format log-port "SWH vault: retrying...~%") - (loop (request-cooking id kind))) + (loop (request-cooking id kind + #:archive-type archive-type))) ((and (or 'new 'pending) status) ;; Wait until the bundle shows up. (let ((message (vault-reply-progress-message reply))) @@ -601,7 +624,8 @@ requested bundle cooking, waiting for completion...~%")) ;; requests per hour per IP address.) (sleep (if (eq? status 'new) 60 30)) - (loop (query-vault id kind))))))))) + (loop (query-vault id kind + #:archive-type archive-type))))))))) ;;; -- cgit v1.2.3 From 60b42bec8413aa9844e625fb1903257f1bc1e55c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 10 Sep 2021 15:51:40 +0200 Subject: swh: 'swh-download' reports revision lookup failures. * guix/swh.scm (swh-download): Log lookup failures. --- guix/swh.scm | 3 +++ 1 file changed, 3 insertions(+) (limited to 'guix') diff --git a/guix/swh.scm b/guix/swh.scm index 3d5d2a410a..a62567dd58 100644 --- a/guix/swh.scm +++ b/guix/swh.scm @@ -697,4 +697,7 @@ wait until it becomes available, which could take several minutes." (swh-download-directory (revision-directory revision) output #:log-port log-port)) (#f + (format log-port + "SWH: revision ~s originating from ~a could not be found~%" + reference url) #f))) -- cgit v1.2.3 From 9875f9bca3976bf3576eab9be42164fde454597e Mon Sep 17 00:00:00 2001 From: Xinglu Chen Date: Mon, 6 Sep 2021 12:57:04 +0200 Subject: import: elpa: Don't hardcode default branch to 'master'. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Otherwise, remotes without a branch named 'master' will cause an error when importing. * guix/import/elpa (git-repository->origin): Fallback to HEAD instead of the 'master' branch. Signed-off-by: Ludovic Courtès --- guix/import/elpa.scm | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/import/elpa.scm b/guix/import/elpa.scm index fb59acc9e3..96ebc17af1 100644 --- a/guix/import/elpa.scm +++ b/guix/import/elpa.scm @@ -259,7 +259,7 @@ RECIPE." ((assoc-ref recipe #:commit) => (lambda (commit) (cons 'commit commit))) (else - '(branch . "master")))) + '()))) (let-values (((directory commit) (download-git-repository url ref))) `(origin -- cgit v1.2.3 From 10c981b1355df694b277a812cd8beb7cd60d1ea6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 7 Sep 2021 18:04:21 +0200 Subject: packages: Store 'location' field as a literal vector. This is slightly more efficient than storing an alist in terms of .go file size (< 1% smaller) and load time. * guix/packages.scm (current-location-vector): New macro. (sanitize-location): New procedure. ()[location]: Change 'default' and add 'sanitize'. (package-location): New procedure. --- guix/packages.scm | 38 ++++++++++++++++++++++++++++++++++---- 1 file changed, 34 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index c825f427d8..01de50ebd7 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -360,6 +360,30 @@ name of its URI." ;; . (fold delete %supported-systems '("mips64el-linux"))) +(define-syntax current-location-vector + (lambda (s) + "Like 'current-source-location' but expand to a literal vector with +one-indexed line numbers." + ;; Storing a literal vector in .go files is more efficient than storing an + ;; alist: less initialization code, fewer relocations, etc. + (syntax-case s () + ((_) + (match (syntax-source s) + (#f #f) + (properties + (let ((file (assq-ref properties 'filename)) + (line (assq-ref properties 'line)) + (column (assq-ref properties 'column))) + (and file line column + #`#(#,file #,(+ 1 line) #,column))))))))) + +(define-inlinable (sanitize-location loc) + ;; Convert LOC to a vector or to #f. + (cond ((vector? loc) loc) + ((not loc) loc) + (else (vector (location-file loc) + (location-line loc) + (location-column loc))))) ;; A package. (define-record-type* @@ -404,10 +428,9 @@ name of its URI." (properties package-properties (default '())) ; alist for anything else - (location package-location - (default (and=> (current-source-location) - source-properties->location)) - (innate))) + (location package-location-vector + (default (current-location-vector)) + (innate) (sanitize sanitize-location))) (set-record-type-printer! (lambda (package port) @@ -425,6 +448,13 @@ name of its URI." package) 16))))) +(define (package-location package) + "Return the source code location of PACKAGE as a record, or #f if +it is not known." + (match (package-location-vector package) + (#f #f) + (#(file line column) (location file line column)))) + (define-syntax-rule (package/inherit p overrides ...) "Like (package (inherit P) OVERRIDES ...), except that the same transformation is done to the package P's replacement, if any. P must be a bare -- cgit v1.2.3 From 8531997d2a1e10d574a6e9ab70bc86ade6af4733 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 7 Sep 2021 21:19:11 +0200 Subject: packages: Add 'package-definition-location'. Suggested by Maxime Devos . * guix/packages.scm (current-definition-location): New syntax parameter. (define-public*): New macro. ()[definition-location]: New field. (package-definition-location): New procedure. * tests/packages.scm ("package-definition-location"): New test. --- guix/packages.scm | 48 +++++++++++++++++++++++++++++++++++++++++++++++- tests/packages.scm | 11 +++++++++++ 2 files changed, 58 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/packages.scm b/guix/packages.scm index 01de50ebd7..ad7937b4fb 100644 --- a/guix/packages.scm +++ b/guix/packages.scm @@ -52,6 +52,7 @@ #:re-export (%current-system %current-target-system search-path-specification) ;for convenience + #:replace ((define-public* . define-public)) #:export (content-hash content-hash? content-hash-algorithm @@ -99,6 +100,7 @@ package-supported-systems package-properties package-location + package-definition-location hidden-package hidden-package? package-superseded @@ -385,6 +387,35 @@ one-indexed line numbers." (location-line loc) (location-column loc))))) +(define-syntax-parameter current-definition-location + ;; Location of the encompassing 'define-public'. + (const #f)) + +(define-syntax define-public* + (lambda (s) + "Like 'define-public' but set 'current-definition-location' for the +lexical scope of its body." + (define location + (match (syntax-source s) + (#f #f) + (properties + (let ((line (assq-ref properties 'line)) + (column (assq-ref properties 'column))) + ;; Don't repeat the file name since it's redundant with 'location'. + ;; Encode the whole thing so that it fits in a fixnum on 32-bit + ;; platforms, which leaves us 29 bits: 7 bits for COLUMN (which is + ;; almost always zero), and 22 bits for LINE. + (and line column + (logior (ash (logand #x7f column) 22) + (logand (- (expt 2 22) 1) (+ 1 line)))))))) + + (syntax-case s () + ((_ prototype body ...) + #`(define-public prototype + (syntax-parameterize ((current-definition-location + (lambda (s) #,location))) + body ...)))))) + ;; A package. (define-record-type* package make-package @@ -430,7 +461,10 @@ one-indexed line numbers." (location package-location-vector (default (current-location-vector)) - (innate) (sanitize sanitize-location))) + (innate) (sanitize sanitize-location)) + (definition-location package-definition-location-code + (default (current-definition-location)) + (innate))) (set-record-type-printer! (lambda (package port) @@ -455,6 +489,18 @@ it is not known." (#f #f) (#(file line column) (location file line column)))) +(define (package-definition-location package) + "Like 'package-location', but return the location of the definition +itself--i.e., that of the enclosing 'define-public' form, if any, or #f." + (match (package-definition-location-code package) + (#f #f) + (code + (let ((column (bit-extract code 22 29)) + (line (bit-extract code 0 21))) + (match (package-location-vector package) + (#f #f) + (#(file _ _) (location file line column))))))) + (define-syntax-rule (package/inherit p overrides ...) "Like (package (inherit P) OVERRIDES ...), except that the same transformation is done to the package P's replacement, if any. P must be a bare diff --git a/tests/packages.scm b/tests/packages.scm index 2a290bc353..3756877270 100644 --- a/tests/packages.scm +++ b/tests/packages.scm @@ -236,6 +236,17 @@ (eq? item new))) (null? (manifest-transaction-remove tx))))))) +(test-assert "package-definition-location" + (let ((location (package-location hello)) + (definition (package-definition-location hello))) + ;; Check for the usual layout of (define-public hello (package ...)). + (and (string=? (location-file location) + (location-file definition)) + (= 0 (location-column definition)) + (= 2 (location-column location)) + (= (location-line definition) + (- (location-line location) 1))))) + (test-assert "package-field-location" (let () (define (goto port line column) -- cgit v1.2.3 From de4f5df95db6c2e7071bf5e44c0d7ae928da1025 Mon Sep 17 00:00:00 2001 From: Efraim Flashner Date: Mon, 26 Apr 2021 21:13:06 +0300 Subject: build/go: Support cross compiling. * guix/build-system/go.scm (go-target): New procedure. (go-build): Add goarch, goos keywords. Adjust bag depending if doing a native or cross compile. (go-cross-build): New procedure. * guix/build/go-build-system.scm (setup-go-environment): Accept goarch, goos keywords. Set go environment variables based on target architecture. * doc/guix.texi (Build Systems): Mention new go-build-system keywords. --- doc/guix.texi | 7 ++ guix/build-system/go.scm | 163 +++++++++++++++++++++++++++++++++++++---- guix/build/go-build-system.scm | 20 ++++- 3 files changed, 172 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 220499503d..2fc9687910 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -7759,6 +7759,13 @@ Packages that provide Go libraries should install their source code into the built output. The key @code{#:install-source?}, which defaults to @code{#t}, controls whether or not the source code is installed. It can be set to @code{#f} for packages that only provide executable files. + +Packages can be cross-built, and if a specific architecture or operating +system is desired then the keywords @code{#:goarch} and @code{#:goos} +can be used to force the package to be built for that architecture and +operating system. The combinations known to Go can be found +@url{"https://golang.org/doc/install/source#environment", in their +documentation}. @end defvr @defvr {Scheme Variable} glib-or-gtk-build-system diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm index 8f55796e86..4c1a732107 100644 --- a/guix/build-system/go.scm +++ b/guix/build-system/go.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016 Petter ;;; Copyright © 2017 Leo Famulari ;;; Copyright © 2020 Jakub Kądziołka +;;; Copyright © 2021 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -27,6 +28,7 @@ #:use-module (guix packages) #:use-module (ice-9 match) #:use-module (ice-9 regex) + #:use-module (srfi srfi-1) #:export (%go-build-system-modules go-build go-build-system @@ -78,6 +80,24 @@ present) if a pseudo-version pattern is not recognized." commit hash and its date rather than a proper release tag." (regexp-exec %go-pseudo-version-rx version)) +(define (go-target target) + ;; Parse the nix-system equivalent of the target and set the + ;; target for compilation accordingly. + (match (string-split (gnu-triplet->nix-system target) #\-) + ((arch os) + (list (match arch + ("aarch64" "arm64") + ("armhf" "arm") + ("powerpc64le" "ppc64le") + ("powerpc64" "ppc64") + ("i686" "386") + ("x86_64" "amd64") + ("mips64el" "mips64le") + (_ arch)) + (match os + ((or "mingw32" "cygwin") "windows") + (_ os)))))) + (define %go-build-system-modules ;; Build-side modules imported and used by default. `((guix build go-build-system) @@ -98,22 +118,37 @@ commit hash and its date rather than a proper release tag." (define private-keywords '(#:source #:target #:go #:inputs #:native-inputs)) - (and (not target) ;XXX: no cross-compilation - (bag - (name name) - (system system) - (host-inputs `(,@(if source - `(("source" ,source)) - '()) - ,@inputs - - ;; Keep the standard inputs of 'gnu-build-system'. - ,@(standard-packages))) - (build-inputs `(("go" ,go) - ,@native-inputs)) - (outputs outputs) - (build go-build) - (arguments (strip-keyword-arguments private-keywords arguments))))) + (bag + (name name) + (system system) + (target target) + (build-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@`(("go" ,go)) + ,@native-inputs + ,@(if target '() inputs) + ,@(if target + ;; Use the standard cross inputs of + ;; 'gnu-build-system'. + (standard-cross-packages target 'host) + '()) + ;; Keep the standard inputs of 'gnu-build-system'. + ,@(standard-packages))) + (host-inputs (if target inputs '())) + + ;; The cross-libc is really a target package, but for bootstrapping + ;; reasons, we can't put it in 'host-inputs'. Namely, 'cross-gcc' is a + ;; native package, so it would end up using a "native" variant of + ;; 'cross-libc' (built with 'gnu-build'), whereas all the other packages + ;; would use a target variant (built with 'gnu-cross-build'.) + (target-inputs (if target + (standard-cross-packages target 'target) + '())) + + (outputs outputs) + (build (if target go-cross-build go-build)) + (arguments (strip-keyword-arguments private-keywords arguments)))) (define* (go-build store name inputs #:key @@ -128,6 +163,8 @@ commit hash and its date rather than a proper release tag." (tests? #t) (allow-go-reference? #f) (system (%current-system)) + (goarch (first (go-target (%current-system)))) + (goos (last (go-target (%current-system)))) (guile #f) (imported-modules %go-build-system-modules) (modules '((guix build go-build-system) @@ -147,6 +184,8 @@ commit hash and its date rather than a proper release tag." #:system ,system #:phases ,phases #:outputs %outputs + #:goarch ,goarch + #:goos ,goos #:search-paths ',(map search-path-specification->sexp search-paths) #:install-source? ,install-source? @@ -174,6 +213,98 @@ commit hash and its date rather than a proper release tag." #:outputs outputs #:guile-for-build guile-for-build)) +(define* (go-cross-build store name + #:key + target native-drvs target-drvs + (phases '(@ (guix build go-build-system) + %standard-phases)) + (outputs '("out")) + (search-paths '()) + (native-search-paths '()) + (install-source? #t) + (import-path "") + (unpack-path "") + (build-flags ''()) + (tests? #f) ; nothing can be done + (allow-go-reference? #f) + (system (%current-system)) + (goarch (first (go-target target))) + (goos (last (go-target target))) + (guile #f) + (imported-modules %go-build-system-modules) + (modules '((guix build go-build-system) + (guix build union) + (guix build utils)))) + "Cross-build NAME using GO, where TARGET is a GNU triplet and with INPUTS." + (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)) + + (go-build #:name ,name + #:source ,(match (assoc-ref native-drvs "source") + (((? derivation? source)) + (derivation->output-path source)) + ((source) + source) + (source + source)) + #:system ,system + #:phases ,phases + #:outputs %outputs + #:target ,target + #:goarch ,goarch + #:goos ,goos + #: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) + #:install-source? ,install-source? + #:import-path ,import-path + #:unpack-path ,unpack-path + #:build-flags ,build-flags + #:tests? ,tests? + #:allow-go-reference? ,allow-go-reference? + #: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 + #:system system + #:inputs (append native-drvs target-drvs) + #:outputs outputs + #:modules imported-modules + #:guile-for-build guile-for-build)) + (define go-build-system (build-system (name 'go) diff --git a/guix/build/go-build-system.scm b/guix/build/go-build-system.scm index 227df820db..645d2fe680 100644 --- a/guix/build/go-build-system.scm +++ b/guix/build/go-build-system.scm @@ -4,7 +4,7 @@ ;;; Copyright © 2019 Maxim Cournoyer ;;; Copyright © 2020 Jack Hill ;;; Copyright © 2020 Jakub Kądziołka -;;; Copyright © 2020 Efraim Flashner +;;; Copyright © 2020, 2021 Efraim Flashner ;;; ;;; This file is part of GNU Guix. ;;; @@ -131,7 +131,7 @@ ;; ;; Code: -(define* (setup-go-environment #:key inputs outputs #:allow-other-keys) +(define* (setup-go-environment #:key inputs outputs goos goarch #:allow-other-keys) "Prepare a Go build environment for INPUTS and OUTPUTS. Build a file system union of INPUTS. Export GOPATH, which helps the compiler find the source code of the package being built and its dependencies, and GOBIN, which determines @@ -149,6 +149,22 @@ dependencies, so it should be self-contained." ;; GOPATH behavior. (setenv "GO111MODULE" "off") (setenv "GOBIN" (string-append (assoc-ref outputs "out") "/bin")) + + ;; Make sure we're building for the correct architecture and OS targets + ;; that Guix targets. + (setenv "GOARCH" goarch) + (setenv "GOOS" goos) + (match goarch + ("arm" + (setenv "GOARM" "7")) + ((or "mips" "mipsel") + (setenv "GOMIPS" "hardfloat")) + ((or "mips64" "mips64le") + (setenv "GOMIPS64" "hardfloat")) + ((or "ppc64" "ppc64le") + (setenv "GOPPC64" "power8")) + (_ #t)) + (let ((tmpdir (tmpnam))) (match (go-inputs inputs) (((names . directories) ...) -- cgit v1.2.3 From 67da64608773772f75983415dd90584025ecd523 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Sep 2021 09:54:12 +0200 Subject: download: Remove obsolete workaround. * guix/download.scm (%content-addressed-mirrors): Use (guix base16) unconditionally. --- guix/download.scm | 8 +------- 1 file changed, 1 insertion(+), 7 deletions(-) (limited to 'guix') diff --git a/guix/download.scm b/guix/download.scm index d60c898c57..a66cf0cea1 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -369,7 +369,7 @@ ;; procedure that takes a file name, an algorithm (symbol) and a hash ;; (bytevector), and returns a URL or #f. '(begin - (use-modules (guix base32)) + (use-modules (guix base16) (guix base32)) (define (guix-publish host) (lambda (file algo hash) @@ -379,12 +379,6 @@ file "/" (symbol->string algo) "/" (bytevector->nix-base32-string hash)))) - ;; XXX: (guix base16) appeared in March 2017 (and thus 0.13.0) so old - ;; installations of the daemon might lack it. Thus, load it lazily to - ;; avoid gratuitous errors. See . - (module-autoload! (current-module) - '(guix base16) '(bytevector->base16-string)) - (list (guix-publish "ci.guix.gnu.org") (lambda (file algo hash) ;; 'tarballs.nixos.org' supports several algorithms. -- cgit v1.2.3 From 3cb5ae8577db28b2c6013b9d9ecf99cb696e3432 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 14 Sep 2021 10:11:42 +0200 Subject: download: Disarchive mirrors can be URL-returning procedures. As discussed at . * guix/build/download.scm (url-fetch)[disarchive-uris]: Accept MIRROR as a procedure. * guix/download.scm (%disarchive-mirrors): Add comment. This change can only be made once a 'guix perform-download' that understands procedures is widely deployed. --- guix/build/download.scm | 23 ++++++++++++++--------- guix/download.scm | 2 ++ 2 files changed, 16 insertions(+), 9 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 54627eefa2..c8ddadfdd4 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -747,15 +747,20 @@ otherwise simply ignore them." content-addressed-mirrors)) (define disarchive-uris - (append-map (match-lambda - ((? string? mirror) - (map (match-lambda - ((hash-algo . hash) - (string->uri - (string-append mirror - (symbol->string hash-algo) "/" - (bytevector->base16-string hash))))) - hashes))) + (append-map (lambda (mirror) + (let ((make-url (match mirror + ((? string?) + (lambda (hash-algo hash) + (string-append + mirror + (symbol->string hash-algo) "/" + (bytevector->base16-string hash)))) + ((? procedure?) + mirror)))) + (map (match-lambda + ((hash-algo . hash) + (string->uri (make-url hash-algo hash)))) + hashes))) disarchive-mirrors)) ;; Make this unbuffered so 'progress-report/file' works as expected. 'line diff --git a/guix/download.scm b/guix/download.scm index a66cf0cea1..85b97a4766 100644 --- a/guix/download.scm +++ b/guix/download.scm @@ -400,6 +400,8 @@ (object->string %content-addressed-mirrors))) (define %disarchive-mirrors + ;; TODO: Eventually turn into a procedure that takes a hash algorithm + ;; (symbol) and hash (bytevector). '("https://disarchive.ngyro.com/")) (define %disarchive-mirror-file -- cgit v1.2.3 From 08c7e7df156e3e61d20fba8a76bea65e1c698ef5 Mon Sep 17 00:00:00 2001 From: Xinglu Chen Date: Sun, 5 Sep 2021 16:05:36 +0200 Subject: scripts: import: Increase column width for pretty-printer. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Previously, the max column width for the pretty-printer was 50, which caused generated package definitions to include unnecessary newlines, e.g., (home-page "https://gitlab.com/ttyperacer/terminal-typeracer") instead of (home-page "https://gitlab.com/ttyperacer/terminal-typeracer") * guix/scripts/import.scm (guix-import): Set max expression width to 80 when pretty-printing. Signed-off-by: Ludovic Courtès --- guix/scripts/import.scm | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 11e94769bb..40fa6759ae 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2018 Kyle Meyer ;;; Copyright © 2019 Ricardo Wurmus ;;; Copyright © 2021 Simon Tournier +;;; Copyright © 2021 Xinglu Chen ;;; ;;; This file is part of GNU Guix. ;;; @@ -118,7 +119,8 @@ Run IMPORTER with ARGS.\n")) (if (member importer importers) (let ((print (lambda (expr) (pretty-print expr (newline-rewriting-port - (current-output-port)))))) + (current-output-port)) + #:max-expr-width 80)))) (match (apply (resolve-importer importer) args) ((and expr (or ('package _ ...) ('let _ ...) -- cgit v1.2.3 From c8e2358cca79f24a0f1183d806e9dd00d6951712 Mon Sep 17 00:00:00 2001 From: Liliana Marie Prikler Date: Tue, 14 Sep 2021 23:27:36 +0200 Subject: build-system: linux-module: Support source-directory. As with guile-build-system, the module to be build need not necessarily live at the root of the build tree. * guix/build/linux-module-build-system.scm (build, install): Add source-directory argument and append it to "M" variable when invoking make. * guix/build-system/linux-module.scm (linux-module-build): Add source-directory argument. --- guix/build-system/linux-module.scm | 4 +++- guix/build/linux-module-build-system.scm | 9 +++++---- 2 files changed, 8 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/build-system/linux-module.scm b/guix/build-system/linux-module.scm index fc3d959ce7..33bc8c95df 100644 --- a/guix/build-system/linux-module.scm +++ b/guix/build-system/linux-module.scm @@ -158,6 +158,7 @@ (outputs '("out")) (make-flags ''()) (system (%current-system)) + (source-directory ".") (guile #f) (substitutable? #t) (imported-modules @@ -175,7 +176,8 @@ ((source) source) (source - source)) + source)) + #:source-directory ,source-directory #:search-paths ',(map search-path-specification->sexp search-paths) #:phases ,phases diff --git a/guix/build/linux-module-build-system.scm b/guix/build/linux-module-build-system.scm index d51d76f94b..729ab6154f 100644 --- a/guix/build/linux-module-build-system.scm +++ b/guix/build/linux-module-build-system.scm @@ -49,16 +49,17 @@ ; TODO: kernel ".config". #t) -(define* (build #:key inputs make-flags #:allow-other-keys) +(define* (build #:key inputs make-flags (source-directory ".") #:allow-other-keys) (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") "/lib/modules/build") - (string-append "M=" (getcwd)) + (string-append "M=" (getcwd) "/" source-directory) (or make-flags '()))) ;; This block was copied from make-linux-libre--only took the "modules_install" ;; part. -(define* (install #:key make-flags inputs native-inputs outputs +(define* (install #:key make-flags (source-directory ".") + inputs native-inputs outputs #:allow-other-keys) (let* ((out (assoc-ref outputs "out")) (moddir (string-append out "/lib/modules"))) @@ -67,7 +68,7 @@ (apply invoke "make" "-C" (string-append (assoc-ref inputs "linux-module-builder") "/lib/modules/build") - (string-append "M=" (getcwd)) + (string-append "M=" (getcwd) "/" source-directory) ;; Disable depmod because the Guix system's module directory ;; is an union of potentially multiple packages. It is not ;; possible to use depmod to usefully calculate a dependency -- cgit v1.2.3 From a840caccaee8c9492f4cc8a7ba802ef54391f199 Mon Sep 17 00:00:00 2001 From: Xinglu Chen Date: Tue, 14 Sep 2021 20:42:18 +0200 Subject: import: cabal: Treat identifier names correctly. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/import/cabal.scm (is-id): Accept the location as an argument. Don’t check if the identifier name is a reserved keyword unless it is the first word on the line. (lex-word): Adjust accordingly. * tests/hackage ("hackage->guix-package tests flag executable"): Expect it to pass. Fixes: Signed-off-by: Lars-Dominik Braun --- guix/import/cabal.scm | 13 ++++++++++--- tests/hackage.scm | 2 -- 2 files changed, 10 insertions(+), 5 deletions(-) (limited to 'guix') diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index e9a0179b3d..98d7234098 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2015 Federico Beffa ;;; Copyright © 2018 Ricardo Wurmus +;;; Copyright © 2021 Xinglu Chen ;;; ;;; This file is part of GNU Guix. ;;; @@ -399,14 +400,20 @@ matching a string against the created regexp." (define (is-or s) (string=? s "||")) -(define (is-id s port) +(define (is-id s port loc) (let ((cabal-reserved-words '("if" "else" "library" "flag" "executable" "test-suite" "custom-setup" "source-repository" "benchmark" "common")) (spaces (read-while (cut char-set-contains? char-set:blank <>) port)) (c (peek-char port))) (unread-string spaces port) - (and (every (cut string-ci<> s <>) cabal-reserved-words) + ;; Sometimes the name of an identifier is the same as one of the reserved + ;; words, which would normally lead to an error, see + ;; . Unless the word + ;; is at the beginning of a line (excluding whitespace), treat is as just + ;; another identifier instead of a reserved word. + (and (or (not (= (source-location-column loc) (current-indentation))) + (every (cut string-ci<> s <>) cabal-reserved-words)) (and (not (char=? (last (string->list s)) #\:)) (not (char=? #\: c)))))) @@ -568,7 +575,7 @@ LOC is the current port location." ((is-none w) (lex-none loc)) ((is-and w) (lex-and loc)) ((is-or w) (lex-or loc)) - ((is-id w port) (lex-id w loc)) + ((is-id w port loc) (lex-id w loc)) (else (unread-string w port) #f)))) (define (lex-line port loc) diff --git a/tests/hackage.scm b/tests/hackage.scm index 53972fc643..aca807027c 100644 --- a/tests/hackage.scm +++ b/tests/hackage.scm @@ -318,8 +318,6 @@ executable cabal mtl >= 2.0 && < 3 ") -;; Fails: https://debbugs.gnu.org/cgi/bugreport.cgi?bug=25138 -(test-expect-fail 1) (test-assert "hackage->guix-package test flag executable" (eval-test-with-cabal test-cabal-flag-executable match-ghc-foo)) -- cgit v1.2.3 From f72f4b48c6777da9465ab17baa6762476d6cb270 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 15 Sep 2021 16:23:48 +0200 Subject: store: 'map/accumulate-builds' processes the whole list in case of cutoff. Fixes . Reported by Lars-Dominik Braun . This fixes a regression introduced in fa81971cbae85b39183ccf8f51e8d96ac88fb4ac whereby 'map/accumulate-builds' would return REST (the tail of LST) without applying PROC on it. The effect would be that 'lower-inputs' in (guix gexp) would dismiss those elements, leading to derivations with correct builders but only a subset of the inputs they should have had. * guix/store.scm (map/accumulate-builds): Add #:cutoff parameter and remove 'accumulation-cutoff' variable. Call PROC on the elements of REST. * tests/store.scm ("map/accumulate-builds cutoff"): New test. --- guix/store.scm | 41 +++++++++++++++++++++++------------------ tests/store.scm | 36 ++++++++++++++++++++++++++++++++++++ 2 files changed, 59 insertions(+), 18 deletions(-) (limited to 'guix') diff --git a/guix/store.scm b/guix/store.scm index 0463b0e8fa..89a719bcfc 100644 --- a/guix/store.scm +++ b/guix/store.scm @@ -1355,14 +1355,16 @@ on the build output of a previous derivation." (unresolved things continue) (continue #t))) -(define (map/accumulate-builds store proc lst) +(define* (map/accumulate-builds store proc lst + #:key (cutoff 30)) "Apply PROC over each element of LST, accumulating 'build-things' calls and -coalescing them into a single call." - (define accumulation-cutoff - ;; Threshold above which we stop accumulating unresolved nodes to avoid - ;; pessimal behavior where we keep stumbling upon the same .drv build - ;; requests with many incoming edges. See . - 30) +coalescing them into a single call. + +CUTOFF is the threshold above which we stop accumulating unresolved nodes." + + ;; The CUTOFF parameter helps avoid pessimal behavior where we keep + ;; stumbling upon the same .drv build requests with many incoming edges. + ;; See . (define-values (result rest) (let loop ((lst lst) @@ -1373,7 +1375,7 @@ coalescing them into a single call." (match (with-build-handler build-accumulator (proc head)) ((? unresolved? obj) - (if (> unresolved accumulation-cutoff) + (if (>= unresolved cutoff) (values (reverse (cons obj result)) tail) (loop tail (cons obj result) (+ 1 unresolved)))) (obj @@ -1390,17 +1392,20 @@ coalescing them into a single call." ;; REST is necessarily empty. result) (to-build - ;; We've accumulated things TO-BUILD. Actually build them and resume the - ;; corresponding continuations. + ;; We've accumulated things TO-BUILD; build them. (build-things store (delete-duplicates to-build)) - (map/accumulate-builds store - (lambda (obj) - (if (unresolved? obj) - ;; Pass #f because 'build-things' is now - ;; unnecessary. - ((unresolved-continuation obj) #f) - obj)) - (append result rest))))) + + ;; Resume the continuations corresponding to TO-BUILD, and then process + ;; REST. + (append (map/accumulate-builds store + (lambda (obj) + (if (unresolved? obj) + ;; Pass #f because 'build-things' is now + ;; unnecessary. + ((unresolved-continuation obj) #f) + obj)) + result #:cutoff cutoff) + (map/accumulate-builds store proc rest #:cutoff cutoff))))) (define build-things (let ((build (operation (build-things (string-list things) diff --git a/tests/store.scm b/tests/store.scm index 3266fa7a82..95f47c3af3 100644 --- a/tests/store.scm +++ b/tests/store.scm @@ -454,6 +454,42 @@ (derivation->output-path drv))) (list d1 d2))))) +(test-equal "map/accumulate-builds cutoff" ;https://issues.guix.gnu.org/50264 + (iota 20) + + ;; Make sure that, when the cutoff is reached, 'map/accumulate-builds' still + ;; returns the right result and calls the build handler by batches. + (let* ((b (add-text-to-store %store "build" "echo $foo > $out" '())) + (s (add-to-store %store "bash" #t "sha256" + (search-bootstrap-binary "bash" + (%current-system)))) + (d (map (lambda (i) + (derivation %store (string-append "the-thing-" + (number->string i)) + s `("-e" ,b) + #:env-vars `(("foo" . ,(random-text))) + #:sources (list b s) + #:properties `((n . ,i)))) + (iota 20))) + (calls '())) + (define lst + (with-build-handler (lambda (continue store things mode) + (set! calls (cons things calls)) + (continue #f)) + (map/accumulate-builds %store + (lambda (d) + (build-derivations %store (list d)) + (assq-ref (derivation-properties d) 'n)) + d + #:cutoff 7))) + + (match (reverse calls) + (((batch1 ...) (batch2 ...) (batch3 ...)) + (and (equal? (map derivation-file-name (take d 8)) batch1) + (equal? (map derivation-file-name (take (drop d 8) 8)) batch2) + (equal? (map derivation-file-name (drop d 16)) batch3) + lst))))) + (test-assert "mapm/accumulate-builds" (let* ((d1 (run-with-store %store (gexp->derivation "foo" #~(mkdir #$output)))) -- cgit v1.2.3