Merge remote-tracking branch 'origin/master' into staging

Conflicts:
	gnu/packages/gnuzilla.scm
	gnu/packages/graphics.scm
	gnu/packages/gstreamer.scm
	gnu/packages/gtk.scm
	gnu/packages/kde-frameworks.scm
	gnu/packages/video.scm

14 files changed, 232 insertions, 92 deletions

diff --git a/guix/channels.scm b/guix/channels.scm
index ad6d3fb8ac..f1c23c17fb 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -419,19 +419,28 @@ their relation.  When AUTHENTICATE? is false, CHANNEL is not authenticated."
     (if authenticate?
         (if (channel-introduction channel)
             (authenticate-channel channel checkout commit)
-            ;; TODO: Warn for all the channels once the authentication interface
-            ;; is public.
-            (when (guix-channel? channel)
-              (raise (make-compound-condition
-                      (formatted-message (G_ "channel '~a' lacks an \
+            (begin
+              (when (file-exists?
+                     (string-append checkout "/.guix-authorizations"))
+                (warning (and=> (channel-location channel)
+                                source-properties->location)
+                         (G_ "channel '~a' lacks 'introduction' field but \
+'.guix-authorizations' found\n")
+                         (channel-name channel)))
+
+              ;; TODO: Warn for all the channels once the authentication interface
+              ;; is public.
+              (when (guix-channel? channel)
+                (raise (make-compound-condition
+                        (formatted-message (G_ "channel '~a' lacks an \
 introduction and cannot be authenticated~%")
-                                         (channel-name channel))
-                      (condition
-                       (&fix-hint
-                        (hint (G_ "Add the missing introduction to your
+                                           (channel-name channel))
+                        (condition
+                         (&fix-hint
+                          (hint (G_ "Add the missing introduction to your
 channels file to address the issue.  Alternatively, you can pass
 @option{--disable-authentication}, at the risk of running unauthenticated and
-thus potentially malicious code."))))))))
+thus potentially malicious code.")))))))))
         (warning (G_ "channel authentication disabled~%")))
 
     (when (guix-channel? channel)
diff --git a/guix/git.scm b/guix/git.scm
index 53e7219c8c..d7fd320f50 100644
--- a/guix/git.scm
+++ b/guix/git.scm
@@ -62,6 +62,7 @@
             commit-difference
             commit-relation
             commit-descendant?
+            commit-id?
 
             remote-refs
 
@@ -219,6 +220,12 @@ of SHA1 string."
     (last (string-split url #\/)) ".git" "")
    "-" (string-take sha1 7)))
 
+(define (commit-id? str)
+  "Return true if STR is likely a Git commit ID, false otherwise---e.g., if it
+is a tag name.  This is based on a simple heuristic so use with care!"
+  (and (= (string-length str) 40)
+       (string-every char-set:hex-digit str)))
+
 (define (resolve-reference repository ref)
   "Resolve the branch, commit or tag specified by REF, and return the
 corresponding Git object."
@@ -254,8 +261,7 @@ corresponding Git object."
                           #f))
                      (_ #f)))
               => (lambda (commit) (resolve `(commit . ,commit))))
-             ((or (> (string-length str) 40)
-                  (not (string-every char-set:hex-digit str)))
+             ((not (commit-id? str))
               (resolve `(tag . ,str)))      ;definitely a tag
              (else
               (catch 'git-error
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index f983debcd2..10a6ec05f1 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -785,8 +785,7 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
   ;; Return true if the given package may be handled by the generic HTML
   ;; updater.
   (let ((hosting-sites '("github.com" "github.io" "gitlab.com"
-                         "notabug.org" "sr.ht"
-                         "gforge.inria.fr" "gitlab.inria.fr"
+                         "notabug.org" "sr.ht" "gitlab.inria.fr"
                          "ftp.gnu.org" "download.savannah.gnu.org"
                          "pypi.org" "crates.io" "rubygems.org"
                          "bioconductor.org")))
diff --git a/guix/import/print.scm b/guix/import/print.scm
index 66016145cb..2f54adbd8c 100644
--- a/guix/import/print.scm
+++ b/guix/import/print.scm
@@ -200,7 +200,8 @@ when evaluated."
          (source ,(source->code source version))
          ,@(match properties
              (() '())
-             (_  `((properties ,properties))))
+             (_  `((properties
+                    ,(list 'quasiquote (object->code properties #t))))))
          ,@(if replacement
                `((replacement ,replacement))
                '())
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index dd8c61b79a..5420037d1d 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -273,29 +273,54 @@ with dashes."
   "Improve the package DESCRIPTION by turning a beginning sentence fragment into
 a proper sentence and by using two spaces between sentences, and wrap lines at
 LENGTH characters."
-  (let ((cleaned (cond
-                  ((not (string? description))
-                   (G_ "This package lacks a description.  Run \
+  (unless (string? description)
+    (G_ "This package lacks a description.  Run \
 \"info '(guix) Synopses and Descriptions'\" for more information."))
-                  ((string-prefix? "A " description)
-                   (string-append "This package provides a"
-                                  (substring description 1)))
-                  ((string-prefix? "Provides " description)
-                   (string-append "This package provides"
-                                  (substring description
-                                             (string-length "Provides"))))
-                  ((string-prefix? "Implements " description)
-                   (string-append "This package implements"
-                                  (substring description
-                                             (string-length "Implements"))))
-                  ((string-prefix? "Functions " description)
-                   (string-append "This package provides functions"
-                                  (substring description
-                                             (string-length "Functions"))))
-                  (else description))))
+
+  (let* ((fix-word
+          (lambda (word)
+            (fold (lambda (proc acc) (proc acc)) word
+                  (list
+                   ;; Remove wrapping in single quotes, common in R packages.
+                   (cut string-trim-both <> #\')
+                   ;; Escape single @ to prevent it from being understood as
+                   ;; invalid Texinfo syntax.
+                   (cut regexp-substitute/global #f "@" <> 'pre "@@" 'post)))))
+         (words
+          (string-tokenize (string-trim-both description)
+                           (char-set-complement
+                            (char-set #\space #\newline))))
+         (new-words
+          (match words
+            (((and (or "A" "Functions" "Methods") first) . rest)
+             (cons* "This" "package" "provides"
+                    (string-downcase first) rest))
+            (((and (or "Contains"
+                       "Creates"
+                       "Performs"
+                       "Provides"
+                       "Produces"
+                       "Implements"
+                       "Infers") first) . rest)
+             (cons* "This" "package"
+                    (string-downcase first) rest))
+            (_ words)))
+         (cleaned
+          (string-join (map fix-word new-words))))
     ;; Use double spacing between sentences
     (fill-paragraph (regexp-substitute/global #f "\\. \\b"
-                                          cleaned 'pre ".  " 'post)
+                                              cleaned 'pre
+                                              (lambda (m)
+                                                (let ((pre (match:prefix m))
+                                                      (abbrevs '("Dr" "Mr" "Mrs"
+                                                                 "Ms" "Prof" "vs"
+                                                                 "e.g")))
+                                                  (if (or (any (cut string-suffix? <> pre) abbrevs)
+                                                          (char-upper-case?
+                                                           (string-ref pre (1- (string-length pre)))))
+                                                      ". "
+                                                      ".  ")))
+                                              'post)
                     length)))
 
 (define (beautify-synopsis synopsis)
@@ -444,10 +469,20 @@ specifications to look up and replace them with plain symbols instead."
                   ((key . value)
                    (list (symbol->keyword (string->symbol key)) value)))
                 arguments))
+  (define (process-properties properties)
+    (map (match-lambda
+           ((key . value)
+            (cons (string->symbol key) value)))
+         properties))
+
   (package
     (name (assoc-ref meta "name"))
     (version (assoc-ref meta "version"))
     (source (source-spec->object (assoc-ref meta "source")))
+    (properties
+     (or (and=> (assoc-ref meta "properties")
+                process-properties)
+         '()))
     (build-system
       (lookup-build-system-by-name
        (string->symbol (assoc-ref meta "build-system"))))
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 20a86bbfda..cbb3c0a36e 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -40,7 +40,7 @@
   #:use-module (guix search-paths)
   #:use-module (guix profiles)
   #:use-module (guix channels)
-  #:use-module ((guix git) #:select (update-cached-checkout))
+  #:use-module ((guix git) #:select (update-cached-checkout commit-id?))
   #:use-module (guix monads)
   #:use-module (guix store)
   #:use-module (guix derivations)
@@ -833,7 +833,7 @@ CHANNEL's 'commit' field is a full SHA1, return it as-is; if it's a SHA1
 prefix, resolve it; and if 'commit' is unset, fetch CHANNEL's branch tip."
   (let ((commit (channel-commit channel))
         (branch (channel-branch channel)))
-    (if (and commit (= (string-length commit) 40))
+    (if (and commit (commit-id? commit))
         commit
         (let* ((ref (if commit `(commit . ,commit) `(branch . ,branch)))
                (cache commit relation
diff --git a/guix/licenses.scm b/guix/licenses.scm
index 3b820ae07e..80cf0f1114 100644
--- a/guix/licenses.scm
+++ b/guix/licenses.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2014, 2015, 2017, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2014, 2015, 2017, 2019, 2020, 2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2013, 2015 Andreas Enge <andreas@enge.fr>
 ;;; Copyright © 2012, 2013 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2015 Mark H Weaver <mhw@netris.org>
@@ -109,13 +109,6 @@
             hpnd
             fsdg-compatible))
 
-(define-record-type <license>
-  (license name uri comment)
-  license?
-  (name    license-name)
-  (uri     license-uri)
-  (comment license-comment))
-
 ;;; Commentary:
 ;;;
 ;;; Available licenses.
@@ -129,6 +122,53 @@
 ;;;
 ;;; Code:
 
+(define-record-type <license>
+  (license name uri comment)
+  actual-license?
+  (name    license-name)
+  (uri     license-uri)
+  (comment license-comment))
+
+(define-syntax define-license-predicate
+  (syntax-rules (define define*)
+    "Define PREDICATE as a license predicate that, when applied to trivial
+cases, reduces to #t at macro-expansion time."
+    ((_ predicate (variables ...) (procedures ...)
+        (define variable _) rest ...)
+     (define-license-predicate
+       predicate
+       (variable variables ...) (procedures ...)
+       rest ...))
+    ((_ predicate (variables ...) (procedures ...)
+        (define* (procedure _ ...) _ ...)
+        rest ...)
+     (define-license-predicate
+       predicate
+       (variables ...) (procedure procedures ...)
+       rest ...))
+    ((_ predicate (variables ...) (procedures ...))
+     (define-syntax predicate
+       (lambda (s)
+         (syntax-case s (variables ... procedures ...)
+           ((_ variables) #t) ...
+           ((_ (procedures _)) #t) ...
+           ((_ obj) #'(actual-license? obj))
+           (id
+            (identifier? #'id)
+            #'actual-license?)))))))
+
+(define-syntax begin-license-definitions
+  (syntax-rules ()
+    ((_ predicate definitions ...)
+     (begin
+       ;; Define PREDICATE such that it expands to #t when passed one of the
+       ;; identifiers in DEFINITIONS.
+       (define-license-predicate predicate () () definitions ...)
+
+       definitions ...))))
+
+(begin-license-definitions license?
+
 (define agpl1
   (license "AGPL 1"
            "https://gnu.org/licenses/agpl.html"
@@ -717,6 +757,6 @@ Data.  More details can be found at URI.  See also
 https://www.gnu.org/distros/free-system-distribution-guidelines.en.html#non-functional-data."
   (license "FSDG-compatible"
            uri
-           comment))
+           comment)))
 
 ;;; licenses.scm ends here
diff --git a/guix/packages.scm b/guix/packages.scm
index 94e464cd01..704b4ee710 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -41,6 +41,9 @@
   #:use-module (guix search-paths)
   #:use-module (guix sets)
   #:use-module (guix deprecation)
+  #:use-module ((guix diagnostics)
+                #:select (formatted-message define-with-syntax-properties))
+  #:autoload   (guix licenses) (license?)
   #:use-module (guix i18n)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
@@ -159,6 +162,8 @@
             &package-error
             package-error?
             package-error-package
+            package-license-error?
+            package-error-invalid-license
             &package-input-error
             package-input-error?
             package-error-invalid-input
@@ -533,6 +538,34 @@ Texinfo.  Otherwise, return the string."
         ((_ obj)
          #'obj)))))
 
+(define-syntax valid-license-value?
+  (syntax-rules (list package-license)
+    "Return #t if the given value is a valid license field, #f otherwise."
+    ;; Arrange so that the answer can be given at macro-expansion time in the
+    ;; most common cases.
+    ((_ (list x ...))
+     (and (license? x) ...))
+    ((_ (package-license _))
+     #t)
+    ((_ obj)
+     (or (license? obj)
+         ;; Note: Avoid 'not' below due to <https://bugs.gnu.org/58217>.
+         (eq? #f obj)                             ;#f is considered valid
+         (let ((x obj))
+           (and (pair? x) (every license? x)))))))
+
+(define-with-syntax-properties (validate-license (value properties))
+  (unless (valid-license-value? value)
+    (raise
+     (make-compound-condition
+      (condition
+       (&error-location
+        (location (source-properties->location properties))))
+      (condition
+       (&package-license-error (package #f) (license value)))
+      (formatted-message (G_ "~s: invalid package license~%") value))))
+  value)
+
 ;; A package.
 (define-record-type* <package>
   package make-package
@@ -574,7 +607,8 @@ Texinfo.  Otherwise, return the string."
             (sanitize validate-texinfo))          ; one-line description
   (description package-description
                (sanitize validate-texinfo))       ; one or two paragraphs
-  (license package-license)                       ; (list of) <license>
+  (license package-license                        ; (list of) <license>
+           (sanitize validate-license))
   (home-page package-home-page)
   (supported-systems package-supported-systems    ; list of strings
                      (default %supported-systems))
@@ -737,6 +771,10 @@ exist, return #f instead."
   package-error?
   (package package-error-package))
 
+(define-condition-type &package-license-error &package-error
+  package-license-error?
+  (license package-error-invalid-license))
+
 (define-condition-type &package-input-error &package-error
   package-input-error?
   (input package-error-invalid-input))
diff --git a/guix/read-print.scm b/guix/read-print.scm
index 65b8cce37d..a9aa57a476 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -277,7 +277,7 @@ expressions and blanks that were read."
    ('lambda 2)
    ('lambda* 2)
    ('match-lambda 1)
-   ('match-lambda* 2)
+   ('match-lambda* 1)
    ('define 2)
    ('define* 2)
    ('define-public 2)
diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm
index 06d9ad1f0c..0787dfcc9a 100644
--- a/guix/scripts/build.scm
+++ b/guix/scripts/build.scm
@@ -383,8 +383,9 @@ use '--no-offload' instead~%")))
                           (format #f (G_ "Did you mean @code{~a}?
 Try @option{--list-targets} to view available targets.~%")
                                   closest))
-                         (display-hint (G_ "\
-Try @option{--list-targets} to view available targets.~%")))
+                         (display-hint
+                          (format #f (G_ "\
+Try @option{--list-targets} to view available targets.~%"))))
                      (exit 1))))))))
 
 (define %standard-native-build-options
@@ -409,8 +410,9 @@ Try @option{--list-targets} to view available targets.~%")))
                           (format #f (G_ "Did you mean @code{~a}?
 Try @option{--list-systems} to view available system types.~%")
                                   closest))
-                         (display-hint (G_ "\
-Try @option{--list-systems} to view available system types.~%")))
+                         (display-hint
+                          (format #f (G_ "\
+Try @option{--list-systems} to view available system types.~%"))))
                      (exit 1))))))))
 
 
diff --git a/guix/scripts/deploy.scm b/guix/scripts/deploy.scm
index 2c76645173..40a9374171 100644
--- a/guix/scripts/deploy.scm
+++ b/guix/scripts/deploy.scm
@@ -256,7 +256,7 @@ otherwise."
         (leave (G_ "missing deployment file argument~%")))
 
       (when (and (pair? command) (not execute-command?))
-        (leave (G_ "'--' was used by '-x' was not specified~%")))
+        (leave (G_ "'--' was used, but '-x' was not specified~%")))
 
       (with-status-verbosity (assoc-ref opts 'verbosity)
         (with-store store
diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm
index bd3cfd2dc3..2bca927d63 100644
--- a/guix/scripts/import.scm
+++ b/guix/scripts/import.scm
@@ -97,7 +97,9 @@ Run IMPORTER with ARGS.\n"))
              ((? list? expressions)
               (for-each (lambda (expr)
                           (print expr)
-                          (newline))
+                          ;; Two newlines: one after the closing paren, and
+                          ;; one to leave a blank line.
+                          (newline) (newline))
                         expressions))
              (x
               (leave (G_ "'~a' import failed~%") importer))))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index 4bcf789703..560f56408c 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -92,6 +92,7 @@
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:export (guix-system
+            read-operating-system
 
             service-node-type
             shepherd-service-node-type))
@@ -107,6 +108,11 @@
                       (gnu services)
                       (gnu system shadow))))
 
+;; Note: The procedure below is used in external projects such as Emacs-Guix.
+(define (read-operating-system file)
+  "Read the operating-system declaration from FILE and return it."
+  (load* file %user-module))
+
 
 ;;;
 ;;; Installation.
diff --git a/guix/transformations.scm b/guix/transformations.scm
index 411c4014cb..bf9639020b 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -43,11 +43,11 @@
 
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
-  #:use-module (srfi srfi-11)
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
   #:use-module (srfi srfi-37)
+  #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
   #:use-module (ice-9 vlist)
   #:export (options->transformation
@@ -115,8 +115,7 @@ extensions."
   "Return a package based on P but with its source taken from URI.  Extract
 the new package's version number from URI."
   (let ((base (tarball-base-name (basename uri))))
-    (let-values (((_ version*)
-                  (hyphen-package-name->name+version base)))
+    (let ((_ version* (hyphen-package-name->name+version base)))
       (package (inherit p)
                (version (or version version*
                             (package-version p)))
@@ -129,42 +128,45 @@ the new package's version number from URI."
 ;;; Transformations.
 ;;;
 
-(define (transform-package-source sources)
-  "Return a transformation procedure that replaces package sources with the
-matching URIs given in SOURCES."
-  (define new-sources
-    (map (lambda (uri)
-           (match (string-index uri #\=)
-             (#f
-              ;; Determine the package name and version from URI.
-              (call-with-values
-                  (lambda ()
-                    (hyphen-package-name->name+version
-                     (tarball-base-name (basename uri))))
-                (lambda (name version)
-                  (list name version uri))))
-             (index
-              ;; What's before INDEX is a "PKG@VER" or "PKG" spec.
-              (call-with-values
-                  (lambda ()
-                    (package-name->name+version (string-take uri index)))
-                (lambda (name version)
-                  (list name version
-                        (string-drop uri (+ 1 index))))))))
-         sources))
+(define (evaluate-source-replacement-specs specs)
+  "Parse SPECS, a list of strings like \"guile=/tmp/guile-4.2.tar.gz\" or just
+\"/tmp/guile-4.2.tar.gz\" and return a list of package spec/procedure pairs as
+expected by 'package-input-rewriting/spec'.  Raise an error if an element of
+SPECS uses invalid syntax."
+  (define not-equal
+    (char-set-complement (char-set #\=)))
 
-  (lambda (obj)
-    (let loop ((sources  new-sources)
-               (result   '()))
-      (match obj
-        ((? package? p)
-         (match (assoc-ref sources (package-name p))
-           ((version source)
-            (package-with-source p source version))
-           (#f
-            p)))
-        (_
-         obj)))))
+  (map (lambda (spec)
+         (match (string-tokenize spec not-equal)
+           ((uri)
+            (let* ((base (tarball-base-name (basename uri)))
+                   (name (hyphen-package-name->name+version base)))
+              (cons name
+                    (lambda (old)
+                      (package-with-source old uri)))))
+           ((spec uri)
+            (let ((name version (package-name->name+version spec)))
+              ;; Note: Here VERSION is used as the version string of the new
+              ;; package rather than as part of the spec of the package being
+              ;; targeted.
+              (cons name
+                    (lambda (old)
+                      (package-with-source old uri version)))))
+           (_
+            (raise (formatted-message
+                    (G_ "invalid source replacement specification: ~s")
+                    spec)))))
+       specs))
+
+(define (transform-package-source replacement-specs)
+  "Return a transformation procedure that replaces package sources with the
+matching URIs given in REPLACEMENT-SPECS."
+  (let* ((replacements (evaluate-source-replacement-specs replacement-specs))
+         (rewrite      (package-input-rewriting/spec replacements)))
+    (lambda (obj)
+      (if (package? obj)
+          (rewrite obj)
+          obj))))
 
 (define (evaluate-replacement-specs specs proc)
   "Parse SPECS, a list of strings like \"guile=guile@2.1\" and return a list