summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
Diffstat (limited to 'guix')
-rw-r--r--guix/base16.scm44
-rw-r--r--guix/base32.scm15
-rw-r--r--guix/build-system/dune.scm19
-rw-r--r--guix/build-system/go.scm163
-rw-r--r--guix/build-system/linux-module.scm2
-rw-r--r--guix/build/download.scm23
-rw-r--r--guix/build/dune-build-system.scm15
-rw-r--r--guix/build/go-build-system.scm20
-rw-r--r--guix/build/linux-module-build-system.scm9
-rw-r--r--guix/download.scm10
-rw-r--r--guix/git.scm33
-rw-r--r--guix/import/cabal.scm13
-rw-r--r--guix/import/elpa.scm4
-rw-r--r--guix/import/go.scm9
-rw-r--r--guix/lint.scm6
-rw-r--r--guix/packages.scm85
-rw-r--r--guix/scripts/import.scm12
-rw-r--r--guix/scripts/system.scm31
-rw-r--r--guix/store.scm41
-rw-r--r--guix/swh.scm87
-rw-r--r--guix/transformations.scm30
21 files changed, 510 insertions, 161 deletions
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 <ludo@gnu.org>
+;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
;;;
;;; 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)
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 <ludo@gnu.org>
+;;; Copyright © 2012, 2015, 2017, 2021 Ludovic Courtès <ludo@gnu.org>
;;;
;;; 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)
diff --git a/guix/build-system/dune.scm b/guix/build-system/dune.scm
index 303b5f76c6..12100fd8e8 100644
--- a/guix/build-system/dune.scm
+++ b/guix/build-system/dune.scm
@@ -61,6 +61,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
'(#:target #:dune #:findlib #:ocaml #:inputs #:native-inputs))
@@ -80,7 +91,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 name inputs
#:key
@@ -91,7 +104,7 @@
(out-of-source? #t)
(jbuild? #f)
(package #f)
- (profile "release")
+ (dune-release-flags ''())
(tests? #t)
(test-flags ''())
(test-target "test")
@@ -131,7 +144,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-system/go.scm b/guix/build-system/go.scm
index 100d1db4b6..b62f2a897b 100644
--- a/guix/build-system/go.scm
+++ b/guix/build-system/go.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2017 Leo Famulari <leo@famulari.name>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -30,6 +31,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
@@ -81,6 +83,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)
@@ -101,22 +121,37 @@ commit hash and its date rather than a proper release tag."
(define private-keywords
'(#: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 name inputs
#:key
@@ -131,6 +166,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)
@@ -145,6 +182,8 @@ commit hash and its date rather than a proper release tag."
#:system #$system
#:phases #$phases
#:outputs #$(outputs->gexp outputs)
+ #:goarch #$goarch
+ #:goos #$goos
#:search-paths '#$(sexp->gexp
(map search-path-specification->sexp
search-paths))
@@ -162,6 +201,98 @@ commit hash and its date rather than a proper release tag."
#:system system
#:guile-for-build guile)))
+(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-system/linux-module.scm b/guix/build-system/linux-module.scm
index 84570b923a..7bafee5a7a 100644
--- a/guix/build-system/linux-module.scm
+++ b/guix/build-system/linux-module.scm
@@ -159,6 +159,7 @@
(outputs '("out"))
(make-flags ''())
(system (%current-system))
+ (source-directory ".")
(guile #f)
(substitutable? #t)
(imported-modules
@@ -172,6 +173,7 @@
(use-modules #$@(sexp->gexp modules))
(linux-module-build #:name #$name
#:source #+source
+ #:source-directory #$source-directory
#:search-paths '#$(sexp->gexp
(map search-path-specification->sexp
search-paths))
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/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)
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 <maxim.cournoyer@gmail.com>
;;; Copyright © 2020 Jack Hill <jackhill@jackhill.us>
;;; Copyright © 2020 Jakub Kądziołka <kuba@kadziolka.net>
-;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2020, 2021 Efraim Flashner <efraim@flashner.co.il>
;;;
;;; 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) ...)
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
diff --git a/guix/download.scm b/guix/download.scm
index d60c898c57..85b97a4766 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 <https://bugs.gnu.org/33542>.
- (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.
@@ -406,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
diff --git a/guix/git.scm b/guix/git.scm
index 9c6f326c36..acc48fd12f 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -2,6 +2,7 @@
;;; Copyright © 2017, 2020 Mathieu Othacehe <m.othacehe@gmail.com>
;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2021 Kyle Meyer <kyle@kyleam.com>
+;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
;;;
;;; 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)))
+ ;; Looks like a 'git describe' style ID, like
+ ;; v1.3.0-7-gaa34d4d28d.
+ (string-drop g+commit 1)
+ #f))
+ (_ #f)))
+ => (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))))
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 <beffa@fbengineering.ch>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; 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
+ ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=25138>. 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/guix/import/elpa.scm b/guix/import/elpa.scm
index 0a1c414c25..05b4a45f2f 100644
--- a/guix/import/elpa.scm
+++ b/guix/import/elpa.scm
@@ -4,6 +4,7 @@
;;; Copyright © 2018 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
;;; Copyright © 2020 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; 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)))
@@ -257,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
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
diff --git a/guix/lint.scm b/guix/lint.scm
index d76a2f5e03..217a0d6696 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -1594,7 +1594,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))
diff --git a/guix/packages.scm b/guix/packages.scm
index 2349bb4340..863c12d528 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -56,6 +56,7 @@
%current-target-system
search-path-specification) ;for convenience
#:re-export-and-replace (delete) ;used as syntactic keyword
+ #:replace ((define-public* . define-public))
#:export (content-hash
content-hash?
content-hash-algorithm
@@ -103,6 +104,7 @@
package-supported-systems
package-properties
package-location
+ package-definition-location
hidden-package
hidden-package?
package-superseded
@@ -388,6 +390,60 @@ not already the case."
inputs)
(else (map add-input-label inputs))))
+(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)))))
+
+(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>
package make-package
@@ -434,10 +490,12 @@ not already the case."
(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))
+ (definition-location package-definition-location-code
+ (default (current-definition-location))
+ (innate)))
(define (add-input-label input)
"Add an input label to INPUT."
@@ -473,6 +531,25 @@ not already the case."
package)
16)))))
+(define (package-location package)
+ "Return the source code location of PACKAGE as a <location> record, or #f if
+it is not known."
+ (match (package-location-vector package)
+ (#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/guix/scripts/import.scm b/guix/scripts/import.scm
index b369a362d0..40fa6759ae 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -3,6 +3,8 @@
;;; Copyright © 2014 David Thompson <davet@gnu.org>
;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
;;; Copyright © 2019 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -117,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 _ ...)
@@ -130,4 +133,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))))))
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 <julien@lepiller.eu>
;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
+;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com>
;;;
;;; 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.
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 <https://bugs.gnu.org/49439>.
- 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 <https://bugs.gnu.org/49439>.
(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/guix/swh.scm b/guix/swh.scm
index 922d781a7b..a62567dd58 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))
;;;
@@ -540,35 +538,57 @@ directory entries; if it has type 'file, return its <content> 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
-<vault-reply> on success."
- ;; <https://docs.softwareheritage.org/devel/swh-vault/api.html#vault-api-ref>
- ;; 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 <vault-reply>."
- (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 <vault-reply> 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 <vault-reply>.
+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
@@ -588,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)))
@@ -603,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)))))))))
;;;
@@ -675,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)))
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 <ludo@gnu.org>
+;;; Copyright © 2021 Marius Bakke <marius@gnu.org>
;;;
;;; 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)))))
generated by cgit v1.2.3 (git 2.47.1) at 2025-01-30 05:17:07 +0000