Merge branch 'master' into gnome-team

8 files changed, 424 insertions, 119 deletions

diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm
index 7c6deb34bf..0d5493ab90 100644
--- a/guix/build-system/perl.scm
+++ b/guix/build-system/perl.scm
@@ -133,7 +133,9 @@ provides a `Makefile.PL' file as its build system."
                                                     search-paths))
                             #:make-maker? #$make-maker?
                             #:make-maker-flags #$make-maker-flags
-                            #:module-build-flags #$(sexp->gexp module-build-flags)
+                            #:module-build-flags #$(if (pair? module-build-flags)
+                                                       (sexp->gexp module-build-flags)
+                                                       module-build-flags)
                             #:phases #$(if (pair? phases)
                                            (sexp->gexp phases)
                                            phases)
diff --git a/guix/channels.scm b/guix/channels.scm
index f01903642d..1b07eb5221 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -34,7 +34,6 @@
   #:use-module (guix packages)
   #:use-module (guix progress)
   #:use-module (guix derivations)
-  #:use-module (guix combinators)
   #:use-module (guix diagnostics)
   #:use-module (guix sets)
   #:use-module (guix store)
@@ -510,16 +509,6 @@ CURRENT-CHANNELS is the list of currently used channels.  It is compared
 against the newly-fetched instances of CHANNELS, and VALIDATE-PULL is called
 for each channel update and can choose to emit warnings or raise an error,
 depending on the policy it implements."
-  ;; Only process channels that are unique, or that are more specific than a
-  ;; previous channel specification.
-  (define (ignore? channel others)
-    (member channel others
-            (lambda (a b)
-              (and (eq? (channel-name a) (channel-name b))
-                   (or (channel-commit b)
-                       (not (or (channel-commit a)
-                                (channel-commit b))))))))
-
   (define (current-commit name)
     ;; Return the current commit for channel NAME.
     (any (lambda (channel)
@@ -527,60 +516,77 @@ depending on the policy it implements."
                 (channel-commit channel)))
          current-channels))
 
+  (define instance-name
+    (compose channel-name channel-instance-channel))
+
+  (define (same-named? channel)
+    (let ((name (channel-name channel)))
+      (lambda (candidate)
+        (eq? (channel-name candidate) name))))
+
+  (define (more-specific? a b)
+    ;; A is more specific than B if it specifies a commit.
+    (and (channel-commit a)
+         (not (channel-commit b))))
+
   (let loop ((channels channels)
-             (previous-channels '()))
-    ;; Accumulate a list of instances.  A list of processed channels is also
-    ;; accumulated to decide on duplicate channel specifications.
-    (define-values (resulting-channels instances)
-      (fold2 (lambda (channel previous-channels instances)
-               (if (ignore? channel previous-channels)
-                   (values previous-channels instances)
-                   (begin
-                     (format (current-error-port)
-                             (G_ "Updating channel '~a' from Git repository at '~a'...~%")
-                             (channel-name channel)
-                             (channel-url channel))
-                     (let* ((current (current-commit (channel-name channel)))
-                            (instance
-                             (latest-channel-instance store channel
-                                                      #:authenticate?
-                                                      authenticate?
-                                                      #:validate-pull
-                                                      validate-pull
-                                                      #:starting-commit
-                                                      current)))
-                       (when authenticate?
-                         ;; CHANNEL is authenticated so we can trust the
-                         ;; primary URL advertised in its metadata and warn
-                         ;; about possibly stale mirrors.
-                         (let ((primary-url (channel-instance-primary-url
-                                             instance)))
-                           (unless (or (not primary-url)
-                                       (channel-commit channel)
-                                       (string=? primary-url (channel-url channel)))
-                             (warning (G_ "pulled channel '~a' from a mirror \
+             (previous-channels '())
+             (instances '()))
+    (match channels
+      (()
+       (reverse instances))
+      ((channel . rest)
+       (let ((previous (find (same-named? channel) previous-channels)))
+         ;; If there's already an instance for CHANNEL, keep the most specific
+         ;; one.
+         (if (and previous
+                  (not (more-specific? channel previous)))
+             (loop rest previous-channels instances)
+             (begin
+               (format (current-error-port)
+                       (G_ "Updating channel '~a' from Git repository at '~a'...~%")
+                       (channel-name channel)
+                       (channel-url channel))
+               (let* ((current (current-commit (channel-name channel)))
+                      (instance
+                       (latest-channel-instance store channel
+                                                #:authenticate?
+                                                authenticate?
+                                                #:validate-pull
+                                                validate-pull
+                                                #:starting-commit
+                                                current)))
+                 (when authenticate?
+                   ;; CHANNEL is authenticated so we can trust the
+                   ;; primary URL advertised in its metadata and warn
+                   ;; about possibly stale mirrors.
+                   (let ((primary-url (channel-instance-primary-url
+                                       instance)))
+                     (unless (or (not primary-url)
+                                 (channel-commit channel)
+                                 (string=? primary-url (channel-url channel)))
+                       (warning (G_ "pulled channel '~a' from a mirror \
 of ~a, which might be stale~%")
-                                      (channel-name channel)
-                                      primary-url))))
-
-                       (let-values (((new-instances new-channels)
-                                     (loop (channel-instance-dependencies instance)
-                                           previous-channels)))
-                         (values (append (cons channel new-channels)
-                                         previous-channels)
-                                 (append (cons instance new-instances)
-                                         instances)))))))
-             previous-channels
-             '()                                  ;instances
-             channels))
-
-    (let ((instance-name (compose channel-name channel-instance-channel)))
-      ;; Remove all earlier channel specifications if they are followed by a
-      ;; more specific one.
-      (values (delete-duplicates instances
-                                 (lambda (a b)
-                                   (eq? (instance-name a) (instance-name b))))
-              resulting-channels))))
+                                (channel-name channel)
+                                primary-url))))
+
+                 ;; Perform a breadth-first traversal with the idea that the
+                 ;; user-provided channels may be more specific than what
+                 ;; '.guix-channel' specifies, and so it is on those instances
+                 ;; that 'channel-instance-dependencies' should be called.
+                 (loop (append rest
+                               (channel-instance-dependencies instance))
+                       (cons channel
+                             (if previous
+                                 (delq previous previous-channels)
+                                 previous-channels))
+                       (cons instance
+                             (if previous
+                                 (remove (lambda (instance)
+                                           (eq? (instance-name instance)
+                                                (channel-name channel)))
+                                         instances)
+                                 instances)))))))))))
 
 (define* (checkout->channel-instance checkout
                                      #:key commit
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index fe1d32d79a..db9250faec 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015-2023 Ricardo Wurmus <rekado@elephly.net>
+;;; Copyright © 2015-2024 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2015-2017, 2019-2021, 2023 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Mathieu Othacehe <m.othacehe@gmail.com>
 ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
@@ -270,7 +270,7 @@ bioconductor package NAME, or #F if the package is unknown."
             ;; of the URLs is the /Archive CRAN URL.
             (any (cut download-to-store store <>) urls)))))))))
 
-(define (fetch-description-from-tarball url)
+(define* (fetch-description-from-tarball url #:key (download download))
   "Fetch the tarball at URL, extra its 'DESCRIPTION' file, parse it, and
 return the resulting alist."
   (match (download url)
@@ -288,7 +288,7 @@ return the resulting alist."
                 (call-with-input-file (string-append dir "/DESCRIPTION")
                   read-string)))))))))
 
-(define* (fetch-description repository name #:optional version)
+(define* (fetch-description repository name #:optional version replacement-download)
   "Return an alist of the contents of the DESCRIPTION file for the R package
 NAME at VERSION in the given REPOSITORY, or #f in case of failure.  NAME is
 case-sensitive."
@@ -310,7 +310,9 @@ from ~a: ~a (~a)~%")
                              (string-append "mirror://cran/src/contrib/Archive/"
                                             name "/"
                                             name "_" version ".tar.gz"))))
-             (fetch-description-from-tarball urls))
+             (fetch-description-from-tarball
+              urls #:download (or replacement-download
+                                  download)))
            (let* ((url    (string-append %cran-url name "/DESCRIPTION"))
                   (port   (http-fetch url))
                   (result (description->alist (read-string port))))
@@ -327,7 +329,9 @@ from ~a: ~a (~a)~%")
                 ;; TODO: Honor VERSION.
                 (version (latest-bioconductor-package-version name type))
                 (url     (car (bioconductor-uri name version type)))
-                (meta    (fetch-description-from-tarball url)))
+                (meta    (fetch-description-from-tarball
+                          url #:download (or replacement-download
+                                             download))))
        (if (boolean? type)
            meta
            (cons `(bioconductor-type . ,type) meta))))
@@ -400,7 +404,8 @@ empty list when the FIELD cannot be found."
 ;; The field for system dependencies is often abused to specify non-package
 ;; dependencies (such as c++11).  This list is used to ignore them.
 (define invalid-packages
-  (list "c++"
+  (list "build-essential"
+        "c++"
         "c++11"
         "c++14"
         "c++17"
@@ -411,6 +416,7 @@ empty list when the FIELD cannot be found."
         "linux"
         "libR"
         "none"
+        "rtools"
         "unix"
         "windows"
         "xcode"
@@ -428,6 +434,9 @@ empty list when the FIELD cannot be found."
     ("freetype2" "freetype")
     ("gettext" "gnu-gettext")
     ("gmake" "gnu-make")
+    ("h5py" "python-h5py")
+    ("hmmer3" "hmmer")
+    ("leidenalg" "python-leidenalg")
     ("libarchive-devel" "libarchive")
     ("libarchive_dev" "libarchive")
     ("libbz2" "bzip2")
@@ -435,13 +444,27 @@ empty list when the FIELD cannot be found."
     ("libjpeg" "libjpeg-turbo")
     ("liblz4" "lz4")
     ("liblzma" "xz")
+    ("libssl-dev" "openssl")
+    ("libssl_dev" "openssl")
     ("libzstd" "zstd")
     ("libxml2-devel" "libxml2")
+    ("libxml2-dev" "libxml2")
     ("libz" "zlib")
+    ("libz-dev" "zlib")
     ("mariadb-devel" "mariadb")
     ("mysql56_dev" "mariadb")
+    ("nodejs" "node")
+    ("numpy" "python-numpy")
+    ("openssl-devel" "openssl")
+    ("openssl@1.1" "openssl-1.1")
+    ("packaging" "python-packaging")
+    ("pandas" "python-pandas")
     ("pandoc-citeproc" "pandoc")
     ("python3" "python-3")
+    ("pytorch" "python-pytorch")
+    ("scikit-learn" "python-scikit-learn")
+    ("scipy" "python-scipy")
+    ("sklearn" "python-scikit-learn")
     ("sqlite3" "sqlite")
     ("svn" "subversion")
     ("tcl/tk" "tcl")
@@ -450,6 +473,7 @@ empty list when the FIELD cannot be found."
     ("x11" "libx11")
     ("xml2" "libxml2")
     ("zlib-devel" "zlib")
+    ("zlib1g-dev" "zlib")
     (_ sysname)))
 
 (define cran-guix-name (cut guix-name "r-" <>))
@@ -648,6 +672,54 @@ of META, a package in REPOSITORY."
             (string<? (upstream-input-downstream-name input1)
                       (upstream-input-downstream-name input2))))))
 
+(define (phases-for-inputs input-names)
+  "Generate a list of build phases based on the provided INPUT-NAMES, a list
+of package names for all input packages."
+  (let ((rules
+         (list (lambda ()
+                 (and (any (lambda (name)
+                             (member name '("styler" "ExperimentHub")))
+                           input-names)
+                      '(add-after 'unpack 'set-HOME
+                         (lambda _ (setenv "HOME" "/tmp")))))
+               (lambda ()
+                 (and (member "esbuild" input-names)
+                      '(add-after 'unpack 'process-javascript
+                         (lambda* (#:key inputs #:allow-other-keys)
+                           (with-directory-excursion "inst/"
+                             (for-each (match-lambda
+                                         ((source . target)
+                                          (minify source #:target target)))
+                                       '())))))))))
+    (fold (lambda (rule phases)
+            (let ((new-phase (rule)))
+              (if new-phase (cons new-phase phases) phases)))
+          (list)
+          rules)))
+
+(define (maybe-arguments inputs)
+  "Generate a list for the arguments field that can be spliced into a package
+S-expression."
+  (let ((input-names (map upstream-input-name inputs))
+        (esbuild-modules '(#:modules
+                           '((guix build r-build-system)
+                             (guix build minify-build-system)
+                             (guix build utils)
+                             (ice-9 match))
+                           #:imported-modules
+                           `(,@%r-build-system-modules
+                             (guix build minify-build-system)))))
+    (match (phases-for-inputs input-names)
+      (() '())
+      (phases
+       `((arguments
+          (list
+           ,@(if (member "esbuild" input-names)
+                 esbuild-modules '())
+           #:phases
+           '(modify-phases %standard-phases
+              ,@phases))))))))
+
 (define* (description->package repository meta #:key (license-prefix identity)
                                (download-source download))
   "Return the `package' s-expression for an R package published on REPOSITORY
@@ -727,7 +799,7 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
                     `((properties ,`(,'quasiquote ((,'upstream-name . ,name)))))
                     '())
               (build-system r-build-system)
-
+              ,@(maybe-arguments inputs)
               ,@(maybe-inputs (filter (upstream-input-type-predicate 'regular)
                                       inputs)
                               'inputs)
@@ -858,15 +930,25 @@ s-expression corresponding to that package, or #f on failure."
   (define upstream-name
     (package->upstream-name pkg))
 
+  (define type
+    (cond
+     ((bioconductor-data-package? pkg)
+      'annotation)
+     ((bioconductor-experiment-package? pkg)
+      'experiment)
+     ((bioconductor-package? pkg)
+      #true)
+     (else #false)))
+
   (define latest-version
-    (latest-bioconductor-package-version upstream-name))
+    (latest-bioconductor-package-version upstream-name type))
 
   (and latest-version
        ;; Bioconductor does not provide signatures.
        (upstream-source
         (package (package-name pkg))
         (version latest-version)
-        (urls (bioconductor-uri upstream-name latest-version))
+        (urls (bioconductor-uri upstream-name latest-version type))
         (inputs
          (let ((meta (fetch-description 'bioconductor upstream-name)))
            (cran-package-inputs meta 'bioconductor))))))
@@ -920,7 +1002,10 @@ s-expression corresponding to that package, or #f on failure."
   (upstream-updater
    (name 'bioconductor)
    (description "Updater for Bioconductor packages")
-   (pred bioconductor-package?)
+   (pred (lambda (pkg)
+           (or (bioconductor-package? pkg)
+               (bioconductor-data-package? pkg)
+               (bioconductor-experiment-package? pkg))))
    (import latest-bioconductor-release)))
 
 ;;; cran.scm ends here
diff --git a/guix/import/crate.scm b/guix/import/crate.scm
index c57bd0bc6a..7a25b2243c 100644
--- a/guix/import/crate.scm
+++ b/guix/import/crate.scm
@@ -5,8 +5,8 @@
 ;;; Copyright © 2021 Nicolas Goaziou <mail@nicolasgoaziou.fr>
 ;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
 ;;; Copyright © 2023 Simon Tournier <zimon.toutoune@gmail.com>
-;;; Copyright © 2023 Efraim Flashner <efraim@flashner.co.il>
-;;; Copyright © 2023 David Elsing <david.elsing@posteo.net>
+;;; Copyright © 2023, 2024 Efraim Flashner <efraim@flashner.co.il>
+;;; Copyright © 2023, 2024 David Elsing <david.elsing@posteo.net>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -104,7 +104,7 @@
 
 ;; Autoload Guile-Semver so we only have a soft dependency.
 (module-autoload! (current-module)
-		  '(semver) '(string->semver semver->string semver<? semver=?))
+		  '(semver) '(string->semver semver->string semver<? semver=? semver>?))
 (module-autoload! (current-module)
 		  '(semver ranges) '(string->semver-range semver-range-contains?))
 
@@ -233,6 +233,39 @@ and LICENSE."
                          'unknown-license!)))
               (string-split string (string->char-set " /"))))
 
+(define (min-element l less)
+  "Returns the smallest element of l according to less or #f if l is empty."
+
+  (let loop ((curr #f)
+             (remaining l))
+    (if (null-list? remaining)
+        curr
+        (let ((next (car remaining))
+              (remaining (cdr remaining)))
+          (if (and curr
+                   (not (less next curr)))
+              (loop curr remaining)
+              (loop next remaining))))))
+
+(define (max-crate-version-of-semver semver-range range)
+  "Returns a <crate-version> of the highest version within the semver range."
+
+  (define (crate->semver crate)
+    (string->semver (crate-version-number crate)))
+
+  (min-element
+   (filter (lambda (crate)
+             (semver-range-contains? semver-range (crate->semver crate)))
+           range)
+   (lambda args
+     (apply semver>? (map crate->semver args)))))
+
+(define (nonyanked-crate-versions crate)
+  "Returns a list of <crate-version>s which are not yanked by upstream."
+  (filter (lambda (entry)
+            (not (crate-version-yanked? entry)))
+          (crate-versions crate)))
+
 (define* (crate->guix-package
           crate-name
           #:key version include-dev-deps? allow-yanked? #:allow-other-keys)
@@ -263,8 +296,8 @@ look up the development dependencs for the given crate."
   ;; Packages previously marked as yanked take lower priority.
   (define (find-package-version name range)
     (let* ((semver-range (string->semver-range range))
-           (package-versions
-            (sort
+           (version
+            (min-element
              (filter (match-lambda ((semver yanked)
                                     (and
                                      (or allow-yanked? (not yanked))
@@ -281,34 +314,22 @@ look up the development dependencs for the given crate."
                              (or (and yanked1 (not yanked2))
                                  (and (eq? yanked1 yanked2)
                                       (semver<? semver1 semver2))))))))
-      (and (not (null-list? package-versions))
-           (match-let (((semver yanked) (last package-versions)))
+      (and (not (eq? #f version))
+           (match-let (((semver yanked) version))
              (list (semver->string semver) yanked)))))
 
   ;; Find the highest version of a crate that fulfills the semver <range>.
   ;; If no matching non-yanked version has been found and allow-yanked? is #t,
   ;; also consider yanked packages.
   (define (find-crate-version crate range)
-    (let* ((semver-range (string->semver-range range))
-           (versions
-            (sort
-             (filter (lambda (entry)
-                       (and
-                         (or allow-yanked?
-                             (not (crate-version-yanked? (second entry))))
-                         (semver-range-contains? semver-range (first entry))))
-                     (map (lambda (ver)
-                            (list (string->semver (crate-version-number ver))
-                                  ver))
-                          (crate-versions crate)))
-             (match-lambda* (((semver ver) ...)
-                             (match-let (((yanked1 yanked2)
-                                          (map crate-version-yanked? ver)))
-                               (or (and yanked1 (not yanked2))
-                                   (and (eq? yanked1 yanked2)
-                                        (apply semver<? semver)))))))))
-      (and (not (null-list? versions))
-           (second (last versions)))))
+    (let ((semver-range (string->semver-range range))
+          (versions     (nonyanked-crate-versions crate)))
+      (or (and (not (null-list? versions))
+               (max-crate-version-of-semver semver-range versions))
+          (and allow-yanked?
+               (not (null-list? (crate-versions crate)))
+               (max-crate-version-of-semver semver-range
+                                            (crate-versions crate))))))
 
   ;; If no non-yanked existing package version was found, check the upstream
   ;; versions.  If a non-yanked upsteam version exists, use it instead,
@@ -427,6 +448,7 @@ look up the development dependencs for the given crate."
 (define (crate-name->package-name name)
   (guix-name "rust-" name))
 
+
 
 ;;;
 ;;; Updater
@@ -440,12 +462,20 @@ look up the development dependencs for the given crate."
 include a VERSION string to fetch a specific version."
   (let* ((crate-name (guix-package->crate-name package))
          (crate      (lookup-crate crate-name))
-         (version    (or version (crate-latest-version crate)))
-         (url        (crate-uri crate-name version)))
-    (upstream-source
-     (package (package-name package))
-     (version version)
-     (urls (list url)))))
+         (version    (or version
+                         (let ((max-crate-version
+                                 (max-crate-version-of-semver
+                                   (string->semver-range
+                                     (string-append "^" (package-version package)))
+                                   (nonyanked-crate-versions crate))))
+                           (and=> max-crate-version
+                                  crate-version-number)))))
+    (if version
+        (upstream-source
+         (package (package-name package))
+         (version version)
+         (urls (list (crate-uri crate-name version))))
+        #f)))
 
 (define %crate-updater
   (upstream-updater
diff --git a/guix/platforms/or1k.scm b/guix/platforms/or1k.scm
new file mode 100644
index 0000000000..bf983085c5
--- /dev/null
+++ b/guix/platforms/or1k.scm
@@ -0,0 +1,28 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2024 Foundation Devices, Inc. <hello@foundationdevices.com>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix platforms or1k)
+  #:use-module (guix platform)
+  #:use-module (guix records)
+  #:export (or1k-elf))
+
+(define or1k-elf
+  (platform
+   (target "or1k-elf")
+   (system #f)
+   (glibc-dynamic-linker #f)))
diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm
index 6d451dc902..449ab4b252 100644
--- a/guix/scripts/describe.scm
+++ b/guix/scripts/describe.scm
@@ -168,6 +168,8 @@ string is ~a.~%")
        (format #t (G_ "  commit: ~a~%") (channel-commit channel)))
       ('channels
        (pretty-print `(list ,(channel->code channel))))
+      ('channels-sans-intro
+       (pretty-print `(list ,(channel->code channel #:include-introduction? #f))))
       ('json
        (display (channel->json channel))
        (newline))
diff --git a/guix/scripts/download.scm b/guix/scripts/download.scm
index 19052d5652..de68e6f328 100644
--- a/guix/scripts/download.scm
+++ b/guix/scripts/download.scm
@@ -22,17 +22,24 @@
   #:use-module (guix scripts)
   #:use-module (guix store)
   #:use-module (gcrypt hash)
+  #:use-module (guix hash)
   #:use-module (guix base16)
   #:use-module (guix base32)
   #:autoload   (guix base64) (base64-encode)
   #:use-module ((guix download) #:hide (url-fetch))
+  #:use-module ((guix git)
+                #:select (latest-repository-commit
+                          update-cached-checkout
+                          with-git-error-handling))
   #:use-module ((guix build download)
                 #:select (url-fetch))
+  #:use-module (guix build utils)
   #:use-module ((guix progress)
                 #:select (current-terminal-columns))
   #:use-module ((guix build syscalls)
                 #:select (terminal-columns))
   #:use-module (web uri)
+  #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
@@ -54,6 +61,57 @@
        (url-fetch url file #:mirrors %mirrors)))
     file))
 
+;; This is a simplified version of 'copy-recursively'.
+;; It allows us to filter out the ".git" subfolder.
+;; TODO: Remove when 'copy-recursively' supports '#:select?'.
+(define (copy-recursively-without-dot-git source destination)
+  (define strip-source
+    (let ((len (string-length source)))
+      (lambda (file)
+        (substring file len))))
+
+  (file-system-fold (lambda (file stat result) ; enter?
+                      (not (string-suffix? "/.git" file)))
+                    (lambda (file stat result) ; leaf
+                      (let ((dest (string-append destination
+                                                 (strip-source file))))
+                        (case (stat:type stat)
+                          ((symlink)
+                           (let ((target (readlink file)))
+                             (symlink target dest)))
+                          (else
+                           (copy-file file dest)))))
+                    (lambda (dir stat result) ; down
+                      (let ((target (string-append destination
+                                                   (strip-source dir))))
+                        (mkdir-p target)))
+                    (const #t)          ; up
+                    (const #t)          ; skip
+                    (lambda (file stat errno result)
+                      (format (current-error-port) "i/o error: ~a: ~a~%"
+                              file (strerror errno))
+                      #f)
+                    #t
+                    source))
+
+(define (git-download-to-file url file reference recursive?)
+  "Download the git repo at URL to file, checked out at REFERENCE.
+REFERENCE must be a pair argument as understood by 'latest-repository-commit'.
+Return FILE."
+  ;; 'libgit2' doesn't support the URL format generated by 'uri->string' so
+  ;; we have to do a little fixup. Dropping completely the 'file:' protocol
+  ;; part gives better performance.
+  (let ((url (cond ((string-prefix? "file://" url)
+                     (string-drop url (string-length "file://")))
+                    ((string-prefix? "file:" url)
+                     (string-drop url (string-length "file:")))
+                    (else url))))
+    (copy-recursively-without-dot-git
+     (with-git-error-handling
+      (update-cached-checkout url #:ref reference #:recursive? recursive?))
+     file))
+  file)
+
 (define (ensure-valid-store-file-name name)
   "Replace any character not allowed in a store name by an underscore."
 
@@ -67,17 +125,46 @@
               name))
 
 
-(define* (download-to-store* url #:key (verify-certificate? #t))
+(define* (download-to-store* url
+                             #:key (verify-certificate? #t)
+                             #:allow-other-keys)
   (with-store store
     (download-to-store store url
                        (ensure-valid-store-file-name (basename url))
                        #:verify-certificate? verify-certificate?)))
 
+(define* (git-download-to-store* url
+                                 reference
+                                 recursive?
+                                 #:key (verify-certificate? #t))
+  "Download the git repository at URL to the store, checked out at REFERENCE.
+URL must specify a protocol (i.e https:// or file://), REFERENCE must be a
+pair argument as understood by 'latest-repository-commit'."
+  ;; Ensure the URL string is properly formatted  when using the 'file'
+  ;; protocol: URL is generated using 'uri->string', which returns
+  ;; "file:/path/to/file" instead of "file:///path/to/file", which in turn
+  ;; makes 'git-download-to-store' fail.
+  (let* ((file? (string-prefix? "file:" url))
+         (url (if (and file?
+                        (not (string-prefix? "file:///" url)))
+                   (string-append "file://"
+                                  (string-drop url (string-length "file:")))
+                   url)))
+    (with-store store
+      ;; TODO: Verify certificate support and deactivation.
+      (with-git-error-handling
+       (latest-repository-commit store
+                                 url
+                                 #:recursive? recursive?
+                                 #:ref reference)))))
+
 (define %default-options
   ;; Alist of default option values.
   `((format . ,bytevector->nix-base32-string)
     (hash-algorithm . ,(hash-algorithm sha256))
     (verify-certificate? . #t)
+    (git-reference . #f)
+    (recursive? . #f)
     (download-proc . ,download-to-store*)))
 
 (define (show-help)
@@ -97,6 +184,19 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
                          do not validate the certificate of HTTPS servers "))
   (format #t (G_ "
   -o, --output=FILE      download to FILE"))
+  (format #t (G_ "
+  -g, --git              download the default branch's latest commit of the
+                         Git repository at URL"))
+  (format #t (G_ "
+      --commit=COMMIT-OR-TAG
+                         download the given commit or tag of the Git
+                         repository at URL"))
+  (format #t (G_ "
+      --branch=BRANCH    download the given branch of the Git repository
+                         at URL"))
+  (format #t (G_ "
+  -r, --recursive        download a Git repository recursively"))
+
   (newline)
   (display (G_ "
   -h, --help             display this help and exit"))
@@ -105,6 +205,13 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
   (newline)
   (show-bug-report-information))
 
+(define (add-git-download-option result)
+  (alist-cons 'download-proc
+              ;; XXX: #:verify-certificate? currently ignored.
+              (lambda* (url #:key verify-certificate? ref recursive?)
+                (git-download-to-store* url ref recursive?))
+              (alist-delete 'download result)))
+
 (define %options
   ;; Specifications of the command-line options.
   (list (option '(#\f "format") #t #f
@@ -136,10 +243,46 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
                   (alist-cons 'verify-certificate? #f result)))
         (option '(#\o "output") #t #f
                 (lambda (opt name arg result)
-                  (alist-cons 'download-proc
-                              (lambda* (url #:key verify-certificate?)
-                                (download-to-file url arg))
-                              (alist-delete 'download result))))
+                  (let* ((git
+                          (assoc-ref result 'git-reference)))
+                    (if git
+                        (alist-cons 'download-proc
+                                    (lambda* (url
+                                              #:key
+                                              verify-certificate?
+                                              ref
+                                              recursive?)
+                                      (git-download-to-file
+                                       url
+                                       arg
+                                       (assoc-ref result 'git-reference)
+                                       recursive?))
+                                    (alist-delete 'download result))
+                        (alist-cons 'download-proc
+                                    (lambda* (url
+                                              #:key verify-certificate?
+                                              #:allow-other-keys)
+                                      (download-to-file url arg))
+                                    (alist-delete 'download result))))))
+        (option '(#\g "git") #f #f
+                (lambda (opt name arg result)
+                  ;; Ignore this option if 'commit' or 'branch' has
+                  ;; already been provided
+                  (if (assoc-ref result 'git-reference)
+                      result
+                      (alist-cons 'git-reference '()
+                                  (add-git-download-option result)))))
+        (option '("commit") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git-reference `(tag-or-commit . ,arg)
+                              (add-git-download-option result))))
+        (option '("branch") #t #f
+                (lambda (opt name arg result)
+                  (alist-cons 'git-reference `(branch . ,arg)
+                              (add-git-download-option result))))
+        (option '(#\r "recursive") #f #f
+                (lambda (opt name arg result)
+                  (alist-cons 'recursive? #t result)))
 
         (option '(#\h "help") #f #f
                 (lambda args
@@ -183,12 +326,14 @@ and 'base16' ('hex' and 'hexadecimal' can be used as well).\n"))
                                   (terminal-columns)))
                     (fetch (uri->string uri)
                            #:verify-certificate?
-                           (assq-ref opts 'verify-certificate?))))
-           (hash  (call-with-input-file
-                      (or path
-                          (leave (G_ "~a: download failed~%")
-                                 arg))
-                    (cute port-hash (assoc-ref opts 'hash-algorithm) <>)))
+                           (assq-ref opts 'verify-certificate?)
+                           #:ref (assq-ref opts 'git-reference)
+                           #:recursive? (assq-ref opts 'recursive?))))
+           (hash  (let* ((path* (or path
+                                  (leave (G_ "~a: download failed~%")
+                                         arg))))
+                   (file-hash* path*
+                               #:algorithm (assoc-ref opts 'hash-algorithm))))
            (fmt   (assq-ref opts 'format)))
       (format #t "~a~%~a~%" path (fmt hash))
       #t)))
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index 2f8985593d..08a1b22a74 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2017-2023 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2017-2024 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2017 Ricardo Wurmus <rekado@elephly.net>
 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;; Copyright © 2020 Simon Tournier <zimon.toutoune@gmail.com>
@@ -388,6 +388,8 @@ Report the availability of substitutes.\n"))
   -m, --manifest=MANIFEST
                          look up substitutes for packages specified in MANIFEST"))
   (display (G_ "
+  -e, --expression=EXPR  build the object EXPR evaluates to"))
+  (display (G_ "
   -c, --coverage[=COUNT]
                          show substitute coverage for packages with at least
                          COUNT dependents"))
@@ -426,6 +428,9 @@ Report the availability of substitutes.\n"))
          (option '(#\m "manifest") #t #f
                  (lambda (opt name arg result)
                    (alist-cons 'manifest arg result)))
+         (option '(#\e "expression") #t #f
+                 (lambda (opt name arg result)
+                   (alist-cons 'expression arg result)))
          (option '(#\c "coverage") #f #t
                  (lambda (opt name arg result)
                    (alist-cons 'coverage
@@ -611,6 +616,8 @@ SERVER.  Display information for packages with at least THRESHOLD dependents."
           (base  (filter-map (match-lambda
                                (('argument . spec)
                                 (specification->package spec))
+                               (('expression . str)
+                                (read/eval-package-expression str))
                                (_
                                 #f))
                              opts)))