Merge branch 'staging' into core-updates

Conflicts resolved in:
	gnu/local.mk
	gnu/packages/cran.scm
	gnu/packages/gnome.scm
	gnu/packages/gtk.scm
	gnu/packages/icu4c.scm
	gnu/packages/java.scm
	gnu/packages/machine-learning.scm
	gnu/packages/tex.scm

12 files changed, 163 insertions, 189 deletions

diff --git a/guix/build-system/go.scm b/guix/build-system/go.scm
index 5e0e5bbad3..4b3b67b08f 100644
--- a/guix/build-system/go.scm
+++ b/guix/build-system/go.scm
@@ -240,45 +240,46 @@ commit hash and its date rather than a proper release tag."
                          (substitutable? #t))
   "Cross-build NAME using GO, where TARGET is a GNU triplet and with INPUTS."
   (define builder
-    #~(begin
-        (use-modules #$@(sexp->gexp modules))
+    (with-imported-modules imported-modules
+      #~(begin
+          (use-modules #$@(sexp->gexp modules))
 
-        (define %build-host-inputs
-          #+(input-tuples->gexp build-inputs))
+          (define %build-host-inputs
+            #+(input-tuples->gexp build-inputs))
 
-        (define %build-target-inputs
-          (append #$(input-tuples->gexp host-inputs)
+          (define %build-target-inputs
+            (append #$(input-tuples->gexp host-inputs)
               #+(input-tuples->gexp target-inputs)))
 
-        (define %build-inputs
-          (append %build-host-inputs %build-target-inputs))
+          (define %build-inputs
+            (append %build-host-inputs %build-target-inputs))
 
-        (define %outputs
-          #$(outputs->gexp outputs))
+          (define %outputs
+            #$(outputs->gexp outputs))
 
-        (go-build #:name #$name
-                  #: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?
-                  #:make-dynamic-linker-cache? #f ;cross-compiling
-                  #:allow-go-reference? #$allow-go-reference?
-                  #:inputs %build-inputs)))
+          (go-build #:name #$name
+                    #: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?
+                    #:make-dynamic-linker-cache? #f ;cross-compiling
+                    #:allow-go-reference? #$allow-go-reference?
+                    #:inputs %build-inputs))))
 
   (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
                                                   system #:graft? #f)))
diff --git a/guix/build/debug-link.scm b/guix/build/debug-link.scm
index 9167737fb3..f3284f74c4 100644
--- a/guix/build/debug-link.scm
+++ b/guix/build/debug-link.scm
@@ -38,10 +38,10 @@
 ;;; create separate debug files (info "(gdb) Separate Debug Files").
 ;;;
 ;;; The main facility of this module is 'graft-debug-links', which allows us
-;;; to update the CRC that appears in '.gnu_debuglink' sections when grafting,
-;;; such that separate debug files remain usable after grafting.  Failing to
-;;; do that, GDB would complain about CRC mismatch---see
-;;; <https://bugs.gnu.org/19973>.
+;;; to update the cyclic redundancy check (CRC) that appears in
+;;; '.gnu_debuglink' sections when grafting, such that separate debug files
+;;; remain usable after grafting.  Failing to do that, GDB would complain
+;;; about CRC mismatch---see <https://issues.guix.gnu.org/19973>.
 ;;;
 ;;; Code:
 
diff --git a/guix/download.scm b/guix/download.scm
index d459ba8cf1..29a8f99034 100644
--- a/guix/download.scm
+++ b/guix/download.scm
@@ -96,15 +96,15 @@
       (hackage
        "http://hackage.haskell.org/")
       (savannah           ; http://download0.savannah.gnu.org/mirmon/savannah/
-       "http://download.savannah.gnu.org/releases/"
-       "http://nongnu.freemirror.org/nongnu/"
-       "http://ftp.cc.uoc.gr/mirrors/nongnu.org/"
-       "http://ftp.twaren.net/Unix/NonGNU/"
-       "http://mirror.csclub.uwaterloo.ca/nongnu/"
-       "http://nongnu.askapache.com/"
-       "http://savannah.c3sl.ufpr.br/"
+       "https://download.savannah.gnu.org/releases/"
+       "https://nongnu.freemirror.org/nongnu/"
+       "https://ftp.cc.uoc.gr/mirrors/nongnu.org/"
+       "http://ftp.twaren.net/Unix/NonGNU/" ; https appears unsupported
+       "https://mirror.csclub.uwaterloo.ca/nongnu/"
+       "https://nongnu.askapache.com/"
+       "https://savannah.c3sl.ufpr.br/"
        "http://download.savannah.gnu.org/releases-noredirect/"
-       "http://download-mirror.savannah.gnu.org/releases/"
+       "https://download-mirror.savannah.gnu.org/releases/"
        "ftp://ftp.twaren.net/Unix/NonGNU/"
        "ftp://mirror.csclub.uwaterloo.ca/nongnu/"
        "ftp://mirror.publicns.net/pub/nongnu/"
@@ -138,6 +138,7 @@
        "http://kernel.osuosl.org/pub/"
        "http://ftp.be.debian.org/pub/"
        "http://mirror.linux.org.au/"
+       "https://mirrors.edge.kernel.org/pub/"
        "ftp://ftp.funet.fi/pub/mirrors/ftp.kernel.org/pub/")
       (apache             ; from http://www.apache.org/mirrors/dist.html
        "http://www.eu.apache.org/dist/"
diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 1ffa408666..f983debcd2 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -33,6 +33,8 @@
   #:use-module (rnrs io ports)
   #:use-module (system foreign)
   #:use-module ((guix http-client) #:hide (open-socket-for-uri))
+  ;; not required in many cases, so autoloaded to reduce start-up costs.
+  #:autoload   (guix download) (%mirrors)
   #:use-module (guix ftp-client)
   #:use-module (guix utils)
   #:use-module (guix memoization)
@@ -58,6 +60,8 @@
             find-package
             gnu-package?
 
+            uri-mirror-rewrite
+
             release-file?
             releases
             latest-release
@@ -359,10 +363,12 @@ return the corresponding signature URL, or #f it signatures are unavailable."
       (upstream-source
        (package project)
        (version (tarball->version file))
-       (urls (list url))
+       ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
+       ;; URLs during "guix refresh -u".
+       (urls (list (uri-mirror-rewrite url)))
        (signature-urls (match (file->signature url)
                          (#f #f)
-                         (sig (list sig)))))))
+                         (sig (list (uri-mirror-rewrite sig))))))))
 
   (let loop ((directory directory)
              (result    #f))
@@ -532,9 +538,12 @@ are unavailable."
                (upstream-source
                 (package package)
                 (version version)
-                (urls (list url))
+                ;; uri-mirror-rewrite: Don't turn nice mirror:// URIs into ftp://
+                ;; URLs during "guix refresh -u".
+                (urls (list (uri-mirror-rewrite url)))
                 (signature-urls
-                 (list ((or file->signature file->signature/guess) url))))))))
+                 (and=> ((or file->signature file->signature/guess) url)
+                        (lambda (url) (list (uri-mirror-rewrite url))))))))))
 
     (define candidates
       (filter-map url->release links))
@@ -651,21 +660,22 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
 (define gnu-hosted?
   (url-prefix-predicate "mirror://gnu/"))
 
-(define (url-prefix-rewrite old new)
-  "Return a one-argument procedure that rewrites URL prefix OLD to NEW."
-  (lambda (url)
-    (if (and url (string-prefix? old url))
-        (string-append new (string-drop url (string-length old)))
-        url)))
-
-(define (adjusted-upstream-source source rewrite-url)
-  "Rewrite URLs in SOURCE by apply REWRITE-URL to each of them."
-  (upstream-source
-   (inherit source)
-   (urls (map rewrite-url (upstream-source-urls source)))
-   (signature-urls (and=> (upstream-source-signature-urls source)
-                          (lambda (urls)
-                            (map rewrite-url urls))))))
+(define (uri-mirror-rewrite uri)
+  "Rewrite URI to a mirror:// URI if possible, or return URI unmodified."
+  (if (string-prefix? "mirror://" uri)
+      uri                            ;nothing to do, it's already a mirror URI
+      (let loop ((mirrors %mirrors))
+        (match mirrors
+          (()
+           uri)
+          (((mirror-id mirror-urls ...) rest ...)
+           (match (find (cut string-prefix? <> uri) mirror-urls)
+             (#f
+              (loop rest))
+             (prefix
+              (format #f "mirror://~a/~a"
+                      mirror-id
+                      (string-drop uri (string-length prefix))))))))))
 
 (define %savannah-base
   ;; One of the Savannah mirrors listed at
@@ -680,15 +690,12 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
                        ((? string? uri) uri)
                        ((uri mirrors ...) uri))))
          (package   (package-upstream-name package))
-         (directory (dirname (uri-path uri)))
-         (rewrite   (url-prefix-rewrite %savannah-base
-                                        "mirror://savannah")))
+         (directory (dirname (uri-path uri))))
     ;; Note: We use the default 'file->signature', which adds ".sig", ".asc",
     ;; or whichever detached signature naming scheme PACKAGE uses.
-    (and=> (latest-html-release package
-                                #:base-url %savannah-base
-                                #:directory directory)
-           (cut adjusted-upstream-source <> rewrite))))
+    (latest-html-release package
+                         #:base-url %savannah-base
+                         #:directory directory)))
 
 (define (latest-sourceforge-release package)
   "Return the latest release of PACKAGE."
@@ -768,14 +775,11 @@ GNOME packages; EMMS is included though, because its releases are on gnu.org."
                        ((? string? uri) uri)
                        ((uri mirrors ...) uri))))
          (package   (package-upstream-name package))
-         (directory (dirname (uri-path uri)))
-         (rewrite   (url-prefix-rewrite %kernel.org-base
-                                        "mirror://kernel.org")))
-    (and=> (latest-html-release package
-                                #:base-url %kernel.org-base
-                                #:directory directory
-                                #:file->signature file->signature)
-           (cut adjusted-upstream-source <> rewrite))))
+         (directory (dirname (uri-path uri))))
+    (latest-html-release package
+                         #:base-url %kernel.org-base
+                         #:directory directory
+                         #:file->signature file->signature)))
 
 (define html-updatable-package?
   ;; Return true if the given package may be handled by the generic HTML
diff --git a/guix/import/cran.scm b/guix/import/cran.scm
index 4e1ce7c010..d7f6945675 100644
--- a/guix/import/cran.scm
+++ b/guix/import/cran.scm
@@ -200,11 +200,11 @@ bioconductor package NAME, or #F if the package is unknown."
 ;; Little helper to download URLs only once.
 (define download
   (memoize
-   (lambda* (url #:key method)
+   (lambda* (url #:key method (ref '()))
      (with-store store
        (cond
         ((eq? method 'git)
-         (latest-repository-commit store url))
+         (latest-repository-commit store url #:ref ref))
         ((eq? method 'hg)
          (call-with-temporary-directory
           (lambda (dir)
@@ -516,32 +516,32 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
          (package
            `(package
               (name ,(cran-guix-name name))
-              (version ,(case repository
-                          ((git)
-                           `(git-version ,version revision commit))
-                          ((hg)
-                           `(string-append ,version "-" revision "." changeset))
-                          (else version)))
+              (version ,(cond
+                         (git?
+                          `(git-version ,version revision commit))
+                         (hg?
+                          `(string-append ,version "-" revision "." changeset))
+                         (else version)))
               (source (origin
                         (method ,(cond
                                   (git? 'git-fetch)
                                   (hg?  'hg-fetch)
                                   (else 'url-fetch)))
-                        (uri ,(case repository
-                                ((git)
-                                 `(git-reference
-                                   (url ,(assoc-ref meta 'git))
-                                   (commit commit)))
-                                ((hg)
-                                 `(hg-reference
-                                   (url ,(assoc-ref meta 'hg))
-                                   (changeset changeset)))
-                                (else
-                                 `(,(procedure-name uri-helper) ,name version
-                                   ,@(or (and=> (assoc-ref meta 'bioconductor-type)
-                                                (lambda (type)
-                                                  (list (list 'quote type))))
-                                         '())))))
+                        (uri ,(cond
+                               (git?
+                                `(git-reference
+                                  (url ,(assoc-ref meta 'git))
+                                  (commit commit)))
+                               (hg?
+                                `(hg-reference
+                                  (url ,(assoc-ref meta 'hg))
+                                  (changeset changeset)))
+                               (else
+                                `(,(procedure-name uri-helper) ,name version
+                                  ,@(or (and=> (assoc-ref meta 'bioconductor-type)
+                                               (lambda (type)
+                                                 (list (list 'quote type))))
+                                        '())))))
                         ,@(cond
                            (git?
                             '((file-name (git-file-name name version))))
@@ -576,16 +576,16 @@ from the alist META, which was derived from the R package's DESCRIPTION file."
                                                       "")))
               (license ,license))))
     (values
-     (case repository
-       ((git)
-        `(let ((commit ,(assoc-ref meta 'git-commit))
-               (revision "1"))
-           ,package))
-       ((hg)
-        `(let ((changeset ,(assoc-ref meta 'hg-changeset))
-               (revision "1"))
-           ,package))
-       (else package))
+     (cond
+      (git?
+       `(let ((commit ,(assoc-ref meta 'git-commit))
+              (revision "1"))
+          ,package))
+      (hg?
+       `(let ((changeset ,(assoc-ref meta 'hg-changeset))
+              (revision "1"))
+          ,package))
+      (else package))
      propagate)))
 
 (define cran->guix-package
diff --git a/guix/lint.scm b/guix/lint.scm
index 7d6fd5ee7e..4ef3a46838 100644
--- a/guix/lint.scm
+++ b/guix/lint.scm
@@ -12,7 +12,7 @@
 ;;; Copyright © 2020 Chris Marusich <cmmarusich@gmail.com>
 ;;; Copyright © 2020 Timothy Sample <samplet@ngyro.com>
 ;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
-;;; Copyright © 2021 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2021, 2022 Maxime Devos <maximedevos@telenet.be>
 ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -1221,22 +1221,14 @@ descriptions maintained upstream."
 
 (define (check-mirror-url package)
   "Check whether PACKAGE uses source URLs that should be 'mirror://'."
-  (define (check-mirror-uri uri)                  ;XXX: could be optimized
-    (let loop ((mirrors %mirrors))
-      (match mirrors
-        (()
-         #f)
-        (((mirror-id mirror-urls ...) rest ...)
-         (match (find (cut string-prefix? <> uri) mirror-urls)
-           (#f
-            (loop rest))
-           (prefix
-            (make-warning package
-                          (G_ "URL should be \
-'mirror://~a/~a'")
-                          (list mirror-id
-                                (string-drop uri (string-length prefix)))
-                          #:field 'source)))))))
+  (define (check-mirror-uri uri)
+    (define rewritten-uri
+      (uri-mirror-rewrite uri))
+
+    (and (not (string=? uri rewritten-uri))
+         (make-warning package (G_ "URL should be '~a'")
+                       (list rewritten-uri)
+                       #:field 'source)))
 
   (let ((origin (package-source package)))
     (if (and (origin? origin)
diff --git a/guix/narinfo.scm b/guix/narinfo.scm
index 4fc550aa6c..741c7ad406 100644
--- a/guix/narinfo.scm
+++ b/guix/narinfo.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2014 Nikita Karetnikov <nikita@karetnikov.org>
 ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com>
 ;;;
@@ -209,7 +209,8 @@ No authentication and authorization checks are performed here!"
 
 (define* (valid-narinfo? narinfo #:optional (acl (current-acl))
                          #:key verbose?)
-  "Return #t if NARINFO's signature is not valid."
+  "Return #t if NARINFO's signature is valid and made by one of the keys in
+ACL."
   (let ((hash      (narinfo-sha256 narinfo))
         (signature (narinfo-signature narinfo))
         (uri       (uri->string (first (narinfo-uris narinfo)))))
diff --git a/guix/platforms/x86.scm b/guix/platforms/x86.scm
index 5338049d6f..6f547dd770 100644
--- a/guix/platforms/x86.scm
+++ b/guix/platforms/x86.scm
@@ -23,7 +23,7 @@
             x86_64-linux
             i686-mingw
             x86_64-mingw
-            hurd))
+            i586-gnu))
 
 (define i686-linux
   (platform
@@ -51,7 +51,7 @@
    (system #f)
    (glibc-dynamic-linker #f)))
 
-(define hurd
+(define i586-gnu
   (platform
    (target "i586-pc-gnu")
    (system "i586-gnu")
diff --git a/guix/read-print.scm b/guix/read-print.scm
index a5a1b708bf..65b8cce37d 100644
--- a/guix/read-print.scm
+++ b/guix/read-print.scm
@@ -337,7 +337,8 @@ expressions and blanks that were read."
 
    ('services '(operating-system))
    ('set-xorg-configuration '())
-   ('services '(home-environment))))
+   ('services '(home-environment))
+   ('home-bash-configuration '(service))))
 
 (define (prefix? candidate lst)
   "Return true if CANDIDATE is a prefix of LST."
@@ -367,10 +368,9 @@ surrounding SYMBOL."
 (define (newline-form? symbol context)
   "Return true if parenthesized expressions starting with SYMBOL must be
 followed by a newline."
-  (match (vhash-assq symbol %newline-forms)
-    (#f #f)
-    ((_ . prefix)
-     (prefix? prefix context))))
+  (let ((matches (vhash-foldq* cons '() symbol %newline-forms)))
+    (find (cut prefix? <> context)
+          matches)))
 
 (define (escaped-string str)
   "Return STR with backslashes and double quotes escaped.  Everything else, in
diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm
index 825ccb1e73..fd263c0699 100644
--- a/guix/scripts/home/import.scm
+++ b/guix/scripts/home/import.scm
@@ -26,9 +26,9 @@
   #:use-module (guix utils)
   #:use-module (guix packages)
   #:autoload   (guix scripts package) (manifest-entry-version-prefix)
+  #:use-module (guix read-print)
   #:use-module (gnu packages)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 pretty-print)
   #:use-module (ice-9 rdelim)
   #:use-module (ice-9 regex)
   #:use-module (ice-9 popen)
@@ -170,8 +170,19 @@ user's files to CONFIGURATION-DIRECTORY; the generated sexp refers to them."
                         (gnu services)
                         ,@(delete-duplicates (concatenate modules)))
 
+           ,(vertical-space 1)
+
            (home-environment
-            (packages (specifications->packages ,packages))
+            ,(comment (G_ "\
+;; Below is the list of packages that will show up in your
+;; Home profile, under ~/.guix-home/profile.\n"))
+            (packages
+             (specifications->packages ,packages))
+
+            ,(vertical-space 1)
+            ,(comment (G_ "\
+;; Below is the list of Home services.  To search for available
+;; services, run 'guix home search KEYWORD' in a terminal.\n"))
             (services (list ,@services)))))))))
 
 (define* (import-manifest
@@ -187,7 +198,5 @@ user's files to CONFIGURATION-DIRECTORY; the generated sexp refers to them."
 ;; specifies package names.  To reproduce the exact same profile, you also
 ;; need to capture the channels being used, as returned by \"guix describe\".
 ;; See the \"Replicating Guix\" section in the manual.\n"))
-     (for-each (lambda (exp)
-                 (newline port)
-                 (pretty-print exp port))
-               exp))))
+     (newline port)
+     (pretty-print-with-comments/splice port exp))))
diff --git a/guix/scripts/pack.scm b/guix/scripts/pack.scm
index d3ee69840c..78b6978c92 100644
--- a/guix/scripts/pack.scm
+++ b/guix/scripts/pack.scm
@@ -48,6 +48,7 @@
   #:use-module (guix scripts build)
   #:use-module (guix transformations)
   #:use-module ((guix self) #:select (make-config.scm))
+  #:use-module (gnu compression)
   #:use-module (gnu packages)
   #:use-module (gnu packages bootstrap)
   #:use-module ((gnu packages compression) #:hide (zip))
@@ -61,13 +62,7 @@
   #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-37)
   #:use-module (ice-9 match)
-  #:export (compressor?
-            compressor-name
-            compressor-extension
-            compressor-command
-            %compressors
-            lookup-compressor
-            self-contained-tarball
+  #:export (self-contained-tarball
             debian-archive
             docker-image
             squashfs-image
@@ -75,34 +70,6 @@
             %formats
             guix-pack))
 
-;; Type of a compression tool.
-(define-record-type <compressor>
-  (compressor name extension command)
-  compressor?
-  (name       compressor-name)      ;string (e.g., "gzip")
-  (extension  compressor-extension) ;string (e.g., ".lz")
-  (command    compressor-command))  ;gexp (e.g., #~(list "/gnu/store/…/gzip"
-                                    ;                    "-9n" ))
-
-(define %compressors
-  ;; Available compression tools.
-  (list (compressor "gzip"  ".gz"
-                    #~(list #+(file-append gzip "/bin/gzip") "-9n"))
-        (compressor "lzip"  ".lz"
-                    #~(list #+(file-append lzip "/bin/lzip") "-9"))
-        (compressor "xz"    ".xz"
-                    #~(append (list #+(file-append xz "/bin/xz")
-                                    "-e")
-                              (%xz-parallel-args)))
-        (compressor "bzip2" ".bz2"
-                    #~(list #+(file-append bzip2 "/bin/bzip2") "-9"))
-        (compressor "zstd" ".zst"
-                    ;; The default level 3 compresses better than gzip in a
-                    ;; fraction of the time, while the highest level 19
-                    ;; (de)compresses more slowly and worse than xz.
-                    #~(list #+(file-append zstd "/bin/zstd") "-3"))
-        (compressor "none" "" #f)))
-
 ;; This one is only for use in this module, so don't put it in %compressors.
 (define bootstrap-xz
   (compressor "bootstrap-xz" ".xz"
@@ -110,15 +77,6 @@
                               "-e")
                         (%xz-parallel-args))))
 
-(define (lookup-compressor name)
-  "Return the compressor object called NAME.  Error out if it could not be
-found."
-  (or (find (match-lambda
-              (($ <compressor> name*)
-               (string=? name* name)))
-            %compressors)
-      (leave (G_ "~a: compressor not found~%") name)))
-
 (define not-config?
   ;; Select (guix …) and (gnu …) modules, except (guix config).
   (match-lambda
diff --git a/guix/scripts/weather.scm b/guix/scripts/weather.scm
index b7d8165262..f46c11b1a5 100644
--- a/guix/scripts/weather.scm
+++ b/guix/scripts/weather.scm
@@ -205,7 +205,6 @@ In case ITEMS is an empty list, return 1 instead."
                     #:make-progress-reporter
                     (lambda* (total #:key url #:allow-other-keys)
                       (progress-reporter/bar total)))))
-    (format #t (highlight "~a~%") server)
     (let ((obtained  (length narinfos))
           (requested (length items))
           (missing   (lset-difference string=?
@@ -224,6 +223,15 @@ In case ITEMS is an empty list, return 1 instead."
                                 (coloring-procedure (color BOLD RED)))
                                (else
                                 highlight))))
+          (format #t (highlight "~a ~a~%") server
+                  ;; This requires a Unicode-capable encoding, which we
+                  ;; restrict to UTF-8 for simplicity.
+                  (if (string=? (port-encoding (current-output-port)) "UTF-8")
+                      (cond ((> ratio 0.80) "☀")
+                            ((< ratio 0.50) "⛈")
+                            (else           "⛅"))
+                      ""))
+
           (format #t
                   (colorize (G_ "  ~,1f% substitutes available (~h out of ~h)~%"))
                   (* 100. ratio)