summaryrefslogtreecommitdiff
path: root/guix
diff options
context:
space:
mode:
authorMarius Bakke <marius@gnu.org>2022-07-22 01:09:14 +0200
committerMarius Bakke <marius@gnu.org>2022-07-22 01:09:14 +0200
commit9044b086ddca64a62966a83cbf1b82d32dece89e (patch)
tree2c7f910c9100b2f2a752d07fe0ec44be83fb7600 /guix
parent5dfc6ab1ab292b87ceea144aa661d0e64c834031 (diff)
parentabea091dbef2d44e6eb46bd2413bdf917e14d095 (diff)
Merge branch 'staging' into core-updates
Diffstat (limited to 'guix')
-rw-r--r--guix/build/profiles.scm34
-rw-r--r--guix/channels.scm15
-rw-r--r--guix/import/egg.scm9
-rw-r--r--guix/import/github.scm5
-rw-r--r--guix/import/pypi.scm8
-rw-r--r--guix/import/texlive.scm20
-rw-r--r--guix/import/utils.scm2
-rw-r--r--guix/inferior.scm12
-rw-r--r--guix/monad-repl.scm64
-rw-r--r--guix/monads.scm18
-rw-r--r--guix/profiles.scm236
-rw-r--r--guix/scripts/challenge.scm5
-rw-r--r--guix/scripts/home.scm64
-rw-r--r--guix/scripts/import/texlive.scm25
-rw-r--r--guix/scripts/package.scm33
-rw-r--r--guix/scripts/shell.scm5
-rw-r--r--guix/scripts/style.scm36
-rw-r--r--guix/scripts/system.scm67
-rw-r--r--guix/upstream.scm25
-rw-r--r--guix/utils.scm6
20 files changed, 480 insertions, 209 deletions
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index f9875ca92e..0c92f222b4 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2015, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2015, 2017-2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -149,19 +149,33 @@ instead make DIRECTORY a \"real\" directory containing symlinks."
"Parse MANIFEST, an sexp as produced by 'manifest->gexp', and return two
values: the list of store items of its manifest entries, and the list of
search path specifications."
+ (define-syntax let-fields
+ (syntax-rules ()
+ ;; Bind the fields NAME of LST to same-named variables in the lexical
+ ;; scope of BODY.
+ ((_ lst (name rest ...) body ...)
+ (let ((name (match (assq 'name lst)
+ ((_ value) value)
+ (#f '()))))
+ (let-fields lst (rest ...) body ...)))
+ ((_ lst () body ...)
+ (begin body ...))))
+
(match manifest ;this must match 'manifest->gexp'
- (('manifest ('version 3)
+ (('manifest ('version (or 3 4))
('packages (entries ...)))
(let loop ((entries entries)
(inputs '())
(search-paths '()))
(match entries
- (((name version output item
- ('propagated-inputs deps)
- ('search-paths paths) _ ...) . rest)
- (loop (append rest deps) ;breadth-first traversal
- (cons item inputs)
- (append paths search-paths)))
+ (((name version output item fields ...) . rest)
+ (let ((paths search-paths))
+ (let-fields fields (propagated-inputs search-paths)
+ (loop (append rest propagated-inputs) ;breadth-first traversal
+ (cons item inputs)
+ (append search-paths paths)))))
+ ((('repeated name version item) . rest)
+ (loop rest inputs search-paths))
(()
(values (reverse inputs)
(delete-duplicates
@@ -212,4 +226,8 @@ search paths of MANIFEST's entries."
;; Write 'OUTPUT/etc/profile'.
(build-etc/profile output search-paths)))
+;;; Local Variables:
+;;; eval: (put 'let-fields 'scheme-indent-function 2)
+;;; End:
+
;;; profile.scm ends here
diff --git a/guix/channels.scm b/guix/channels.scm
index ce1a60436f..689b30e0eb 100644
--- a/guix/channels.scm
+++ b/guix/channels.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2018, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2018-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; Copyright © 2019 Jan (janneke) Nieuwenhuizen <janneke@gnu.org>
;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re>
@@ -896,7 +896,12 @@ specified."
(define (package-cache-file manifest)
"Build a package cache file for the instance in MANIFEST. This is meant to
be used as a profile hook."
- (let ((profile (profile (content manifest) (hooks '()))))
+ ;; Note: Emit a profile in format version 3, which was introduced in 2017
+ ;; and is readable by Guix since before version 1.0. This ensures that the
+ ;; Guix in MANIFEST is able to read the manifest file created for its own
+ ;; profile below. See <https://issues.guix.gnu.org/56441>.
+ (let ((profile (profile (content manifest) (hooks '())
+ (format-version 3))))
(define build
#~(begin
(use-modules (gnu packages))
@@ -937,8 +942,12 @@ be used as a profile hook."
"Return the derivation of the profile containing INSTANCES, a list of
channel instances."
(mlet %store-monad ((manifest (channel-instances->manifest instances)))
+ ;; Emit a profile in format version so that, if INSTANCES denotes an old
+ ;; Guix, it can still read that profile, for instance for the purposes of
+ ;; 'guix describe'.
(profile-derivation manifest
- #:hooks %channel-profile-hooks)))
+ #:hooks %channel-profile-hooks
+ #:format-version 3)))
(define latest-channel-instances*
(store-lift latest-channel-instances))
diff --git a/guix/import/egg.scm b/guix/import/egg.scm
index 0b88020554..52196583c4 100644
--- a/guix/import/egg.scm
+++ b/guix/import/egg.scm
@@ -85,11 +85,6 @@
(define %eggs-home-page
(make-parameter "https://wiki.call-cc.org/egg"))
-(define (egg-source-url name version)
- "Return the URL to the source tarball for version VERSION of the CHICKEN egg
-NAME."
- `(egg-uri ,name version))
-
(define (egg-name->guix-name name)
"Return the package name for CHICKEN egg NAME."
(string-append package-name-prefix name))
@@ -196,7 +191,7 @@ not work."
(let* ((version* (or (assoc-ref egg-content 'version)
(find-latest-version name)))
(version (if (list? version*) (first version*) version*))
- (source-url (if source #f (egg-source-url name version)))
+ (source-url (if source #f `(egg-uri ,name version)))
(tarball (if source
#f
(with-store store
@@ -342,7 +337,7 @@ not work."
"Return an @code{<upstream-source>} for the latest release of PACKAGE."
(let* ((egg-name (guix-package->egg-name package))
(version (find-latest-version egg-name))
- (source-url (egg-source-url egg-name version)))
+ (source-url (egg-uri egg-name version)))
(upstream-source
(package (package-name package))
(version version)
diff --git a/guix/import/github.scm b/guix/import/github.scm
index 51118d1d39..e1a1af7133 100644
--- a/guix/import/github.scm
+++ b/guix/import/github.scm
@@ -5,6 +5,7 @@
;;; Copyright © 2019 Arun Isaac <arunisaac@systemreboot.net>
;;; Copyright © 2019 Efraim Flashner <efraim@flashner.co.il>
;;; Copyright © 2022 Maxime Devos <maximedevos@telenet.be>
+;;; Copyright © 2022 Hartmut Goebel <h.goebel@crazy-compilers.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -95,8 +96,8 @@ false if none is recognized"
((string-suffix? (string-append "/releases/download/" repo "-"
version "/" repo "-" version ext)
url)
- (string-append "/releases/download/" repo "-" version "/" repo "-"
- version ext))
+ (string-append prefix "/releases/download/" repo "-" new-version "/"
+ repo "-" new-version ext))
(#t #f))) ; Some URLs are not recognised.
#f))
diff --git a/guix/import/pypi.scm b/guix/import/pypi.scm
index 392fc9700b..4760fc3dae 100644
--- a/guix/import/pypi.scm
+++ b/guix/import/pypi.scm
@@ -161,9 +161,11 @@ or #f if there isn't any."
(define (python->package-name name)
"Given the NAME of a package on PyPI, return a Guix-compliant name for the
package."
- (if (string-prefix? "python-" name)
- (snake-case name)
- (string-append "python-" (snake-case name))))
+ (cond
+ ((string-prefix? "python-" name) (snake-case name))
+ ((or (string=? "trytond" name)
+ (string-prefix? "trytond-" name)) (snake-case name))
+ (else (string-append "python-" (snake-case name)))))
(define (guix-package->pypi-name package)
"Given a Python PACKAGE built from pypi.org, return the name of the
diff --git a/guix/import/texlive.scm b/guix/import/texlive.scm
index c741555928..116bd1f66a 100644
--- a/guix/import/texlive.scm
+++ b/guix/import/texlive.scm
@@ -246,7 +246,7 @@ of those files are returned that are unexpectedly installed."
;; entries with the same prefix.
(lambda (x y) (every equal? x y)))))
-(define (tlpdb->package name package-database)
+(define (tlpdb->package name version package-database)
(and-let* ((data (assoc-ref package-database name))
(dirs (files->directories
(map (lambda (dir)
@@ -255,7 +255,9 @@ of those files are returned that are unexpectedly installed."
(or (assoc-ref data 'runfiles) (list))
(or (assoc-ref data 'srcfiles) (list))))))
(name (guix-name name))
- (version (number->string %texlive-revision))
+ ;; TODO: we're ignoring the VERSION argument because that
+ ;; information is distributed across %texlive-tag and
+ ;; %texlive-revision.
(ref (svn-multi-reference
(url (string-append "svn://www.tug.org/texlive/tags/"
%texlive-tag "/Master/texmf-dist"))
@@ -276,6 +278,9 @@ of those files are returned that are unexpectedly installed."
(force-output port)
(get-hash))))
,@(if (assoc-ref data 'srcfiles) '() '(#:trivial? #true))))
+ ;; package->definition in (guix import utils) expects to see a
+ ;; version field.
+ (version ,version)
,@(or (and=> (assoc-ref data 'depend)
(lambda (inputs)
`((propagated-inputs
@@ -297,13 +302,18 @@ of those files are returned that are unexpectedly installed."
(define texlive->guix-package
(memoize
- (lambda* (name #:key repo version (package-database tlpdb))
+ (lambda* (name #:key
+ repo
+ (version (number->string %texlive-revision))
+ (package-database tlpdb))
"Find the metadata for NAME in the tlpdb and return the `package'
s-expression corresponding to that package, or #f on failure."
- (tlpdb->package name (package-database)))))
+ (tlpdb->package name version (package-database)))))
-(define (texlive-recursive-import name)
+(define* (texlive-recursive-import name #:key repo version)
(recursive-import name
+ #:repo repo
+ #:version version
#:repo->guix-package texlive->guix-package
#:guix-name guix-name))
diff --git a/guix/import/utils.scm b/guix/import/utils.scm
index 26eebfece5..668b8c8083 100644
--- a/guix/import/utils.scm
+++ b/guix/import/utils.scm
@@ -341,6 +341,8 @@ APPEND-VERSION?/string is a string, append this string."
(match guix-package
((or
('package ('name name) ('version version) . rest)
+ ('package ('inherit ('simple-texlive-package name . _))
+ ('version version) . rest)
('let _ ('package ('name name) ('version version) . rest)))
`(define-public ,(string->symbol
diff --git a/guix/inferior.scm b/guix/inferior.scm
index 54200b75e4..20a86bbfda 100644
--- a/guix/inferior.scm
+++ b/guix/inferior.scm
@@ -156,12 +156,18 @@ custom binary port)."
(close-port parent)
(close-fdes 0)
(close-fdes 1)
+ (close-fdes 2)
(dup2 (fileno child) 0)
(dup2 (fileno child) 1)
;; Mimic 'open-pipe*'.
- (unless (file-port? (current-error-port))
- (close-fdes 2)
- (dup2 (open-fdes "/dev/null" O_WRONLY) 2))
+ (if (file-port? (current-error-port))
+ (let ((error-port-fileno
+ (fileno (current-error-port))))
+ (unless (eq? error-port-fileno 2)
+ (dup2 error-port-fileno
+ 2)))
+ (dup2 (open-fdes "/dev/null" O_WRONLY)
+ 2))
(apply execlp command command args))
(lambda ()
(primitive-_exit 127))))
diff --git a/guix/monad-repl.scm b/guix/monad-repl.scm
index aefabdeebb..8a6053edd5 100644
--- a/guix/monad-repl.scm
+++ b/guix/monad-repl.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2014, 2015, 2016, 2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -21,6 +21,12 @@
#:use-module (guix monads)
#:use-module (guix utils)
#:use-module (guix packages)
+ #:use-module (guix status)
+ #:autoload (guix gexp) (lower-object)
+ #:use-module ((guix derivations)
+ #:select (derivation?
+ derivation->output-paths built-derivations))
+ #:use-module (ice-9 match)
#:use-module (ice-9 pretty-print)
#:use-module (system repl repl)
#:use-module (system repl common)
@@ -69,16 +75,58 @@
#:guile-for-build guile)
'store-monad)))
+(define %build-verbosity
+ ;; Current build verbosity level.
+ 1)
+
+(define* (evaluate/print-with-store mvalue #:key build?)
+ "Run monadic value MVALUE in the store monad and print its value."
+ (with-store store
+ (set-build-options store
+ #:print-build-trace #t
+ #:print-extended-build-trace? #t
+ #:multiplexed-build-output? #t)
+ (with-status-verbosity %build-verbosity
+ (let* ((guile (or (%guile-for-build)
+ (default-guile-derivation store)))
+ (values (run-with-store store
+ (if build?
+ (mlet %store-monad ((obj mvalue))
+ (if (derivation? obj)
+ (mbegin %store-monad
+ (built-derivations (list obj))
+ (return
+ (match (derivation->output-paths obj)
+ (((_ . files) ...) files))))
+ (return (list obj))))
+ (mlet %store-monad ((obj mvalue))
+ (return (list obj))))
+ #:guile-for-build guile)))
+ (for-each (lambda (value)
+ (run-hook before-print-hook value)
+ (pretty-print value))
+ values)))))
+
(define-meta-command ((run-in-store guix) repl (form))
"run-in-store EXP
Run EXP through the store monad."
- (with-store store
- (let* ((guile (or (%guile-for-build)
- (default-guile-derivation store)))
- (value (run-with-store store (repl-eval repl form)
- #:guile-for-build guile)))
- (run-hook before-print-hook value)
- (pretty-print value))))
+ (evaluate/print-with-store (repl-eval repl form)))
+
+(define-meta-command ((verbosity guix) repl (level))
+ "verbosity LEVEL
+Change build verbosity to LEVEL."
+ (set! %build-verbosity (repl-eval repl level)))
+
+(define-meta-command ((lower guix) repl (form))
+ "lower OBJECT
+Lower OBJECT into a derivation or store file and return it."
+ (evaluate/print-with-store (lower-object (repl-eval repl form))))
+
+(define-meta-command ((build guix) repl (form))
+ "build OBJECT
+Lower OBJECT and build it, returning its output file name(s)."
+ (evaluate/print-with-store (lower-object (repl-eval repl form))
+ #:build? #t))
(define-meta-command ((enter-store-monad guix) repl)
"enter-store-monad
diff --git a/guix/monads.scm b/guix/monads.scm
index 6ae616aca9..0bd8ac9315 100644
--- a/guix/monads.scm
+++ b/guix/monads.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2013, 2014, 2015, 2017 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2013, 2014, 2015, 2017, 2022 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -40,6 +40,7 @@
mbegin
mwhen
munless
+ mparameterize
lift0 lift1 lift2 lift3 lift4 lift5 lift6 lift7 lift
listm
foldm
@@ -398,6 +399,21 @@ expression."
(mbegin %current-monad
mexp0 mexp* ...)))))
+(define-syntax mparameterize
+ (syntax-rules ()
+ "This form implements dynamic scoping, similar to 'parameterize', but in a
+monadic context."
+ ((_ monad ((parameter value) rest ...) body ...)
+ (let ((old-value (parameter)))
+ (mbegin monad
+ ;; XXX: Non-local exits are not correctly handled.
+ (return (parameter value))
+ (mlet monad ((result (mparameterize monad (rest ...) body ...)))
+ (parameter old-value)
+ (return result)))))
+ ((_ monad () body ...)
+ (mbegin monad body ...))))
+
(define-syntax define-lift
(syntax-rules ()
((_ liftn (args ...))
diff --git a/guix/profiles.scm b/guix/profiles.scm
index d3ff8379ad..6aaaa4f6c0 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -453,63 +453,80 @@ denoting a specific output of a package."
packages)
manifest-entry=?)))
-(define (manifest->gexp manifest)
- "Return a representation of MANIFEST as a gexp."
+(define %manifest-format-version
+ ;; The current manifest format version.
+ 4)
+
+(define* (manifest->gexp manifest #:optional
+ (format-version %manifest-format-version))
+ "Return a representation in FORMAT-VERSION of MANIFEST as a gexp."
+ (define (optional name value)
+ (match format-version
+ (4
+ (if (null? value)
+ #~()
+ #~((#$name #$value))))
+ (3
+ (match name
+ ('properties #~((#$name #$@value)))
+ (_ #~((#$name #$value)))))))
+
(define (entry->gexp entry)
- (match entry
- (($ <manifest-entry> name version output (? string? path)
- (deps ...) (search-paths ...) _ (properties ...))
- #~(#$name #$version #$output #$path
- (propagated-inputs #$(map entry->gexp deps))
- (search-paths #$(map search-path-specification->sexp
- search-paths))
- #$@(if (null? properties)
- #~()
- #~((properties . #$properties)))))
- (($ <manifest-entry> name version output package
- (deps ...) (search-paths ...) _ (properties ...))
- #~(#$name #$version #$output
- (ungexp package (or output "out"))
- (propagated-inputs #$(map entry->gexp deps))
- (search-paths #$(map search-path-specification->sexp
- search-paths))
- #$@(if (null? properties)
- #~()
- #~((properties . #$properties)))))))
+ ;; Maintain in state monad a vhash of visited entries, indexed by their
+ ;; item, usually package objects (we cannot use the entry itself as an
+ ;; index since identical entries are usually not 'eq?'). Use that vhash
+ ;; to avoid repeating duplicate entries. This is particularly useful in
+ ;; the presence of propagated inputs, where we could otherwise end up
+ ;; repeating large trees.
+ (mlet %state-monad ((visited (current-state)))
+ (if (and (= format-version 4)
+ (match (vhash-assq (manifest-entry-item entry) visited)
+ ((_ . previous-entry)
+ (manifest-entry=? previous-entry entry))
+ (#f #f)))
+ (return #~(repeated #$(manifest-entry-name entry)
+ #$(manifest-entry-version entry)
+ (ungexp (manifest-entry-item entry)
+ (manifest-entry-output entry))))
+ (mbegin %state-monad
+ (set-current-state (vhash-consq (manifest-entry-item entry)
+ entry visited))
+ (mlet %state-monad ((deps (mapm %state-monad entry->gexp
+ (manifest-entry-dependencies entry))))
+ (return
+ (match entry
+ (($ <manifest-entry> name version output (? string? path)
+ (_ ...) (search-paths ...) _ (properties ...))
+ #~(#$name #$version #$output #$path
+ #$@(optional 'propagated-inputs deps)
+ #$@(optional 'search-paths
+ (map search-path-specification->sexp
+ search-paths))
+ #$@(optional 'properties properties)))
+ (($ <manifest-entry> name version output package
+ (_deps ...) (search-paths ...) _ (properties ...))
+ #~(#$name #$version #$output
+ (ungexp package (or output "out"))
+ #$@(optional 'propagated-inputs deps)
+ #$@(optional 'search-paths
+ (map search-path-specification->sexp
+ search-paths))
+ #$@(optional 'properties properties))))))))))
+
+ (unless (memq format-version '(3 4))
+ (raise (formatted-message
+ (G_ "cannot emit manifests formatted as version ~a")
+ format-version)))
(match manifest
(($ <manifest> (entries ...))
- #~(manifest (version 3)
- (packages #$(map entry->gexp entries))))))
-
-(define (find-package name version)
- "Return a package from the distro matching NAME and possibly VERSION. This
-procedure is here for backward-compatibility and will eventually vanish."
- (define find-best-packages-by-name ;break abstractions
- (module-ref (resolve-interface '(gnu packages))
- 'find-best-packages-by-name))
-
- ;; Use 'find-best-packages-by-name' and not 'find-packages-by-name'; the
- ;; former traverses the module tree only once and then allows for efficient
- ;; access via a vhash.
- (match (find-best-packages-by-name name version)
- ((p _ ...) p)
- (_
- (match (find-best-packages-by-name name #f)
- ((p _ ...) p)
- (_ #f)))))
+ #~(manifest (version #$format-version)
+ (packages #$(run-with-state
+ (mapm %state-monad entry->gexp entries)
+ vlist-null))))))
(define (sexp->manifest sexp)
"Parse SEXP as a manifest."
- (define (infer-search-paths name version)
- ;; Infer the search path specifications for NAME-VERSION by looking up a
- ;; same-named package in the distro. Useful for the old manifest formats
- ;; that did not store search path info.
- (let ((package (find-package name version)))
- (if package
- (package-native-search-paths package)
- '())))
-
(define (infer-dependency item parent)
;; Return a <manifest-entry> for ITEM.
(let-values (((name version)
@@ -521,14 +538,15 @@ procedure is here for backward-compatibility and will eventually vanish."
(item item)
(parent parent))))
- (define* (sexp->manifest-entry sexp #:optional (parent (delay #f)))
+ (define* (sexp->manifest-entry/v3 sexp #:optional (parent (delay #f)))
+ ;; Read SEXP as a version 3 manifest entry.
(match sexp
((name version output path
('propagated-inputs deps)
('search-paths search-paths)
extra-stuff ...)
;; For each of DEPS, keep a promise pointing to ENTRY.
- (letrec* ((deps* (map (cut sexp->manifest-entry <> (delay entry))
+ (letrec* ((deps* (map (cut sexp->manifest-entry/v3 <> (delay entry))
deps))
(entry (manifest-entry
(name name)
@@ -543,45 +561,58 @@ procedure is here for backward-compatibility and will eventually vanish."
'())))))
entry))))
+ (define-syntax let-fields
+ (syntax-rules ()
+ ;; Bind the fields NAME of LST to same-named variables in the lexical
+ ;; scope of BODY.
+ ((_ lst (name rest ...) body ...)
+ (let ((name (match (assq 'name lst)
+ ((_ value) value)
+ (#f '()))))
+ (let-fields lst (rest ...) body ...)))
+ ((_ lst () body ...)
+ (begin body ...))))
+
+ (define* (sexp->manifest-entry sexp #:optional (parent (delay #f)))
+ (match sexp
+ (('repeated name version path)
+ ;; This entry is the same as another one encountered earlier; look it
+ ;; up and return it.
+ (mlet %state-monad ((visited (current-state))
+ (key -> (list name version path)))
+ (match (vhash-assoc key visited)
+ (#f
+ (raise (formatted-message
+ (G_ "invalid repeated entry in profile: ~s")
+ sexp)))
+ ((_ . entry)
+ (return entry)))))
+ ((name version output path fields ...)
+ (let-fields fields (propagated-inputs search-paths properties)
+ (mlet* %state-monad
+ ((entry -> #f)
+ (deps (mapm %state-monad
+ (cut sexp->manifest-entry <> (delay entry))
+ propagated-inputs))
+ (visited (current-state))
+ (key -> (list name version path)))
+ (set! entry ;XXX: emulate 'letrec*'
+ (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (item path)
+ (dependencies deps)
+ (search-paths (map sexp->search-path-specification
+ search-paths))
+ (parent parent)
+ (properties properties)))
+ (mbegin %state-monad
+ (set-current-state (vhash-cons key entry visited))
+ (return entry)))))))
+
(match sexp
- (('manifest ('version 0)
- ('packages ((name version output path) ...)))
- (manifest
- (map (lambda (name version output path)
- (manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (search-paths (infer-search-paths name version))))
- name version output path)))
-
- ;; Version 1 adds a list of propagated inputs to the
- ;; name/version/output/path tuples.
- (('manifest ('version 1)
- ('packages ((name version output path deps) ...)))
- (manifest
- (map (lambda (name version output path deps)
- ;; Up to Guix 0.7 included, dependencies were listed as ("gmp"
- ;; "/gnu/store/...-gmp") for instance. Discard the 'label' in
- ;; such lists.
- (let ((deps (match deps
- (((labels directories) ...)
- directories)
- ((directories ...)
- directories))))
- (letrec* ((deps* (map (cute infer-dependency <> (delay entry))
- deps))
- (entry (manifest-entry
- (name name)
- (version version)
- (output output)
- (item path)
- (dependencies deps*)
- (search-paths
- (infer-search-paths name version)))))
- entry)))
- name version output path deps)))
+ ;; Versions 0 and 1 are no longer produced since 2015.
;; Version 2 adds search paths and is slightly more verbose.
(('manifest ('version 2 minor-version ...)
@@ -609,7 +640,15 @@ procedure is here for backward-compatibility and will eventually vanish."
;; Version 3 represents DEPS as full-blown manifest entries.
(('manifest ('version 3 minor-version ...)
('packages (entries ...)))
- (manifest (map sexp->manifest-entry entries)))
+ (manifest (map sexp->manifest-entry/v3 entries)))
+
+ ;; Version 4 deduplicates repeated entries and makes manifest entry fields
+ ;; such as 'propagated-inputs' and 'search-paths' optional.
+ (('manifest ('version 4 minor-version ...)
+ ('packages (entries ...)))
+ (manifest (run-with-state
+ (mapm %state-monad sexp->manifest-entry entries)
+ vlist-null)))
(_
(raise (condition
(&message (message "unsupported manifest format")))))))
@@ -1862,6 +1901,7 @@ MANIFEST."
(allow-unsupported-packages? #f)
(allow-collisions? #f)
(relative-symlinks? #f)
+ (format-version %manifest-format-version)
system target)
"Return a derivation that builds a profile (aka. 'user environment') with
the given MANIFEST. The profile includes additional derivations returned by
@@ -1947,7 +1987,7 @@ are cross-built for TARGET."
#+(if locales? set-utf8-locale #t)
- (build-profile #$output '#$(manifest->gexp manifest)
+ (build-profile #$output '#$(manifest->gexp manifest format-version)
#:extra-inputs '#$extra-inputs
#:symlink #$(if relative-symlinks?
#~symlink-relative
@@ -1986,19 +2026,23 @@ are cross-built for TARGET."
(allow-collisions? profile-allow-collisions? ;Boolean
(default #f))
(relative-symlinks? profile-relative-symlinks? ;Boolean
- (default #f)))
+ (default #f))
+ (format-version profile-format-version ;integer
+ (default %manifest-format-version)))
(define-gexp-compiler (profile-compiler (profile <profile>) system target)
"Compile PROFILE to a derivation."
(match profile
(($ <profile> name manifest hooks
- locales? allow-collisions? relative-symlinks?)
+ locales? allow-collisions? relative-symlinks?
+ format-version)
(profile-derivation manifest
#:name name
#:hooks hooks
#:locales? locales?
#:allow-collisions? allow-collisions?
#:relative-symlinks? relative-symlinks?
+ #:format-version format-version
#:system system #:target target))))
(define* (profile-search-paths profile
@@ -2318,4 +2362,8 @@ PROFILE refers to, directly or indirectly, or PROFILE."
%known-shorthand-profiles)
profile))
+;;; Local Variables:
+;;; eval: (put 'let-fields 'scheme-indent-function 2)
+;;; End:
+
;;; profiles.scm ends here
diff --git a/guix/scripts/challenge.scm b/guix/scripts/challenge.scm
index 5c0f837d13..f1e5f67dab 100644
--- a/guix/scripts/challenge.scm
+++ b/guix/scripts/challenge.scm
@@ -537,8 +537,9 @@ Challenge the substitutes for PACKAGE... provided by one or more servers.\n"))
(current-terminal-columns (terminal-columns)))
(let ((files (match files
(()
- (filter (cut locally-built? store <>)
- (live-paths store)))
+ (warning
+ (G_ "no arguments specified, nothing to do~%"))
+ (exit 0))
(x
files))))
(set-build-options store
diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm
index 8ba7693a83..ae830d0b48 100644
--- a/guix/scripts/home.scm
+++ b/guix/scripts/home.scm
@@ -5,6 +5,7 @@
;;; Copyright © 2021 Oleg Pykhalov <go.wigust@gmail.com>
;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2022 Antero Mejr <antero@mailbox.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -144,6 +145,11 @@ Some ACTIONS support additional ARGS.\n"))
use BACKEND for 'extension-graph' and 'shepherd-graph'"))
(newline)
(display (G_ "
+ -I, --list-installed[=REGEXP]
+ for 'describe' or 'list-generations', list installed
+ packages matching REGEXP"))
+ (newline)
+ (display (G_ "
-h, --help display this help and exit"))
(display (G_ "
-V, --version display version information and exit"))
@@ -184,6 +190,9 @@ Some ACTIONS support additional ARGS.\n"))
(option '("graph-backend") #t #f
(lambda (opt name arg result)
(alist-cons 'graph-backend arg result)))
+ (option '(#\I "list-installed") #f #t
+ (lambda (opt name arg result)
+ (alist-cons 'list-installed (or arg "") result)))
;; Container options.
(option '(#\N "network") #f #f
@@ -570,17 +579,20 @@ Run @command{guix home reconfigure ~a/home-configuration.scm} to effectively
deploy the home environment described by these files.\n")
destination))))
((describe)
- (match (generation-number %guix-home)
- (0
- (leave (G_ "no home environment generation, nothing to describe~%")))
- (generation
- (display-home-environment-generation generation))))
+ (let ((list-installed-regex (assoc-ref opts 'list-installed)))
+ (match (generation-number %guix-home)
+ (0
+ (leave (G_ "no home environment generation, nothing to describe~%")))
+ (generation
+ (display-home-environment-generation
+ generation #:list-installed-regex list-installed-regex)))))
((list-generations)
- (let ((pattern (match args
+ (let ((list-installed-regex (assoc-ref opts 'list-installed))
+ (pattern (match args
(() #f)
((pattern) pattern)
(x (leave (G_ "wrong number of arguments~%"))))))
- (list-generations pattern)))
+ (list-generations pattern #:list-installed-regex list-installed-regex)))
((switch-generation)
(let ((pattern (match args
((pattern) pattern)
@@ -749,9 +761,11 @@ description matches REGEXPS sorted by relevance, and their score."
(define* (display-home-environment-generation
number
- #:optional (profile %guix-home))
- "Display a summary of home-environment generation NUMBER in a
-human-readable format."
+ #:optional (profile %guix-home)
+ #:key (list-installed-regex #f))
+ "Display a summary of home-environment generation NUMBER in a human-readable
+format. List packages in that home environment that match
+LIST-INSTALLED-REGEX."
(define (display-channel channel)
(format #t " ~a:~%" (channel-name channel))
(format #t (G_ " repository URL: ~a~%") (channel-url channel))
@@ -783,24 +797,36 @@ human-readable format."
(format #t (G_ " configuration file: ~a~%")
(if (supports-hyperlinks?)
(file-hyperlink config-file)
- config-file))))))
-
-(define* (list-generations pattern #:optional (profile %guix-home))
- "Display in a human-readable format all the home environment
-generations matching PATTERN, a string. When PATTERN is #f, display
-all the home environment generations."
+ config-file)))
+ (when list-installed-regex
+ (format #t (G_ " packages:\n"))
+ (pretty-print-table (list-installed
+ list-installed-regex
+ (list (string-append generation "/profile")))
+ #:left-pad 4)))))
+
+(define* (list-generations pattern #:optional (profile %guix-home)
+ #:key (list-installed-regex #f))
+ "Display in a human-readable format all the home environment generations
+matching PATTERN, a string. When PATTERN is #f, display all the home
+environment generations. List installed packages that match
+LIST-INSTALLED-REGEX."
(cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error
(profile profile)))))
((not pattern)
- (for-each display-home-environment-generation (profile-generations profile)))
+ (for-each (cut display-home-environment-generation <>
+ #:list-installed-regex list-installed-regex)
+ (profile-generations profile)))
((matching-generations pattern profile)
=>
(lambda (numbers)
(if (null-list? numbers)
(exit 1)
- (leave-on-EPIPE
- (for-each display-home-environment-generation numbers)))))))
+ (leave-on-EPIPE (for-each
+ (cut display-home-environment-generation <>
+ #:list-installed-regex list-installed-regex)
+ numbers)))))))
;;;
diff --git a/guix/scripts/import/texlive.scm b/guix/scripts/import/texlive.scm
index c5dcc07ea1..203386e31c 100644
--- a/guix/scripts/import/texlive.scm
+++ b/guix/scripts/import/texlive.scm
@@ -22,11 +22,13 @@
#:use-module (guix utils)
#:use-module (guix scripts)
#:use-module (guix import texlive)
+ #:use-module (guix import utils)
#:use-module (guix scripts import)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-11)
#:use-module (srfi srfi-37)
#:use-module (srfi srfi-41)
+ #:use-module (srfi srfi-71)
#:use-module (ice-9 match)
#:use-module (ice-9 format)
#:export (guix-import-texlive))
@@ -58,6 +60,9 @@ Import and convert the Texlive package for PACKAGE-NAME.\n"))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix import texlive")))
+ (option '(#\r "recursive") #f #f
+ (lambda (opt name arg result)
+ (alist-cons 'recursive #t result)))
%standard-import-options))
@@ -78,12 +83,20 @@ Import and convert the Texlive package for PACKAGE-NAME.\n"))
(_ #f))
(reverse opts))))
(match args
- ((name)
- (let ((sexp (texlive->guix-package name)))
- (unless sexp
- (leave (G_ "failed to import package '~a'~%")
- name))
- sexp))
+ ((spec)
+ (let ((name version (package-name->name+version spec)))
+ (if (assoc-ref opts 'recursive)
+ ;; Recursive import
+ (with-error-handling
+ (map package->definition
+ (filter identity (texlive-recursive-import name
+ #:version version))))
+ ;; Single import
+ (let ((sexp (texlive->guix-package name #:version version)))
+ (unless sexp
+ (leave (G_ "failed to download description for package '~a'~%")
+ name))
+ sexp))))
(()
(leave (G_ "too few arguments~%")))
((many ...)
diff --git a/guix/scripts/package.scm b/guix/scripts/package.scm
index 14a8e1f5e8..404925cb5a 100644
--- a/guix/scripts/package.scm
+++ b/guix/scripts/package.scm
@@ -12,6 +12,7 @@
;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com>
;;; Copyright © 2022 Josselin Poiret <dev@jpoiret.xyz>
;;; Copyright © 2022 Arun Isaac <arunisaac@systemreboot.net>
+;;; Copyright © 2022 Antero Mejr <antero@mailbox.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -68,6 +69,7 @@
delete-generations
delete-matching-generations
guix-package
+ list-installed
search-path-environment-variables
manifest-entry-version-prefix
@@ -774,6 +776,22 @@ doesn't need it."
(add-indirect-root store absolute))
+(define (list-installed regexp profiles)
+ "Write to the current output port the list of packages matching REGEXP in
+PROFILES."
+ (let* ((regexp (and regexp (make-regexp* regexp regexp/icase)))
+ (manifest (concatenate-manifests
+ (map profile-manifest profiles)))
+ (installed (manifest-entries manifest)))
+ (leave-on-EPIPE
+ (let ((rows (filter-map
+ (match-lambda
+ (($ <manifest-entry> name version output path _)
+ (and (regexp-exec regexp name)
+ (list name (or version "?") output path))))
+ installed)))
+ rows))))
+
;;;
;;; Queries and actions.
@@ -825,19 +843,8 @@ processed, #f otherwise."
#t)
(('list-installed regexp)
- (let* ((regexp (and regexp (make-regexp* regexp regexp/icase)))
- (manifest (concatenate-manifests
- (map profile-manifest profiles)))
- (installed (manifest-entries manifest)))
- (leave-on-EPIPE
- (let ((rows (filter-map
- (match-lambda
- (($ <manifest-entry> name version output path _)
- (and (regexp-exec regexp name)
- (list name (or version "?") output path))))
- installed)))
- ;; Show most recently installed packages last.
- (pretty-print-table (reverse rows)))))
+ ;; Show most recently installed packages last.
+ (pretty-print-table (reverse (list-installed regexp profiles)))
#t)
(('list-available regexp)
diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm
index 004ed7af2e..c115a00320 100644
--- a/guix/scripts/shell.scm
+++ b/guix/scripts/shell.scm
@@ -390,6 +390,11 @@ return #f and #f."
;; If the user already specified a profile, there's nothing more to
;; cache.
(values #f #f))
+ ((('export-manifest? . #t) . _)
+ ;; When exporting a manifest, compute it anew so that '-D' packages
+ ;; lead to 'package-development-manifest' expressions rather than an
+ ;; expanded list of inputs.
+ (values #f #f))
((('system . system) . rest)
(loop rest system file specs))
((_ . rest) (loop rest system file specs)))))
diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm
index ca3853af5e..9fd652beb1 100644
--- a/guix/scripts/style.scm
+++ b/guix/scripts/style.scm
@@ -44,6 +44,7 @@
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
+ #:use-module (srfi srfi-34)
#:use-module (srfi srfi-37)
#:export (pretty-print-with-comments
read-with-comments
@@ -272,6 +273,16 @@ included in the output.
Lists longer than LONG-LIST are written as one element per line. Comments are
passed through FORMAT-COMMENT before being emitted; a useful value for
FORMAT-COMMENT is 'canonicalize-comment'."
+ (define (list-of-lists? head tail)
+ ;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of
+ ;; 'let' bindings.
+ (match head
+ ((thing _ ...) ;proper list
+ (and (not (memq thing
+ '(quote quasiquote unquote unquote-splicing)))
+ (pair? tail)))
+ (_ #f)))
+
(let loop ((indent indent)
(column indent)
(delimited? #t) ;true if comes after a delimiter
@@ -436,7 +447,8 @@ FORMAT-COMMENT is 'canonicalize-comment'."
(column (if overflow?
(+ indent 1)
(+ column (if delimited? 1 2))))
- (newline? (newline-form? head context))
+ (newline? (or (newline-form? head context)
+ (list-of-lists? head tail))) ;'let' bindings
(context (cons head context)))
(if overflow?
(begin
@@ -672,7 +684,16 @@ doing it."
"Replace the file name in LOC by an absolute location."
(location (if (string-prefix? "/" (location-file loc))
(location-file loc)
- (search-path %load-path (location-file loc)))
+
+ ;; 'search-path' might return #f in obscure cases, such as
+ ;; when %LOAD-PATH includes "." or ".." and LOC comes from a
+ ;; file in a subdirectory thereof.
+ (match (search-path %load-path (location-file loc))
+ (#f
+ (raise (formatted-message
+ (G_ "file '~a' not found on load path")
+ (location-file loc))))
+ (str str)))
(location-line loc)
(location-column loc)))
@@ -798,15 +819,26 @@ PACKAGE."
(lambda args
(show-help)
(exit 0)))
+ (option '(#\l "list-stylings") #f #f
+ (lambda args
+ (show-stylings)
+ (exit 0)))
(option '(#\V "version") #f #f
(lambda args
(show-version-and-exit "guix style")))))
+(define (show-stylings)
+ (display (G_ "Available styling rules:\n"))
+ (display (G_ "- format: Format the given package definition(s)\n"))
+ (display (G_ "- inputs: Rewrite package inputs to the “new style”\n")))
+
(define (show-help)
(display (G_ "Usage: guix style [OPTION]... [PACKAGE]...
Update package definitions to the latest style.\n"))
(display (G_ "
-S, --styling=RULE apply RULE, a styling rule"))
+ (display (G_ "
+ -l, --list-stylings display the list of available style rules"))
(newline)
(display (G_ "
-n, --dry-run display files that would be edited but do nothing"))
diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm
index b9084a401c..bfde0a88ca 100644
--- a/guix/scripts/system.scm
+++ b/guix/scripts/system.scm
@@ -50,7 +50,8 @@
#:use-module (guix channels)
#:use-module (guix scripts build)
#:autoload (guix scripts package) (delete-generations
- delete-matching-generations)
+ delete-matching-generations
+ list-installed)
#:autoload (guix scripts pull) (channel-commit-hyperlink)
#:autoload (guix graph) (export-graph node-type
graph-backend-name lookup-backend)
@@ -480,8 +481,10 @@ list of services."
;;;
(define* (display-system-generation number
- #:optional (profile %system-profile))
- "Display a summary of system generation NUMBER in a human-readable format."
+ #:optional (profile %system-profile)
+ #:key (list-installed-regex #f))
+ "Display a summary of system generation NUMBER in a human-readable format.
+List packages in that system that match LIST-INSTALLED-REGEX."
(define (display-channel channel)
(format #t " ~a:~%" (channel-name channel))
(format #t (G_ " repository URL: ~a~%") (channel-url channel))
@@ -544,23 +547,35 @@ list of services."
(format #t (G_ " configuration file: ~a~%")
(if (supports-hyperlinks?)
(file-hyperlink config-file)
- config-file))))))
-
-(define* (list-generations pattern #:optional (profile %system-profile))
+ config-file)))
+ (when list-installed-regex
+ (format #t (G_ " packages:\n"))
+ (pretty-print-table (list-installed
+ list-installed-regex
+ (list (string-append generation "/profile")))
+ #:left-pad 4)))))
+
+(define* (list-generations pattern #:optional (profile %system-profile)
+ #:key (list-installed-regex #f))
"Display in a human-readable format all the system generations matching
-PATTERN, a string. When PATTERN is #f, display all the system generations."
+PATTERN, a string. When PATTERN is #f, display all the system generations.
+List installed packages that match LIST-INSTALLED-REGEX."
(cond ((not (file-exists? profile)) ; XXX: race condition
(raise (condition (&profile-not-found-error
(profile profile)))))
((not pattern)
- (for-each display-system-generation (profile-generations profile)))
+ (for-each (cut display-system-generation <>
+ #:list-installed-regex list-installed-regex)
+ (profile-generations profile)))
((matching-generations pattern profile)
=>
(lambda (numbers)
(if (null-list? numbers)
(exit 1)
(leave-on-EPIPE
- (for-each display-system-generation numbers)))))))
+ (for-each (cut display-system-generation <>
+ #:list-installed-regex list-installed-regex)
+ numbers)))))))
;;;
@@ -1032,6 +1047,11 @@ Some ACTIONS support additional ARGS.\n"))
use BACKEND for 'extension-graphs' and 'shepherd-graph'"))
(newline)
(display (G_ "
+ -I, --list-installed[=REGEXP]
+ for 'describe' and 'list-generations', list installed
+ packages matching REGEXP"))
+ (newline)
+ (display (G_ "
-h, --help display this help and exit"))
(display (G_ "
-V, --version display version information and exit"))
@@ -1135,6 +1155,9 @@ Some ACTIONS support additional ARGS.\n"))
(option '("graph-backend") #t #f
(lambda (opt name arg result)
(alist-cons 'graph-backend arg result)))
+ (option '(#\I "list-installed") #f #t
+ (lambda (opt name arg result)
+ (alist-cons 'list-installed (or arg "") result)))
%standard-build-options))
(define %default-options
@@ -1322,25 +1345,29 @@ argument list and OPTS is the option alist."
;; The following commands do not need to use the store, and they do not need
;; an operating system configuration file.
((list-generations)
- (let ((pattern (match args
+ (let ((list-installed-regex (assoc-ref opts 'list-installed))
+ (pattern (match args
(() #f)
((pattern) pattern)
(x (leave (G_ "wrong number of arguments~%"))))))
- (list-generations pattern)))
+ (list-generations pattern #:list-installed-regex list-installed-regex)))
((describe)
;; Describe the running system, which is not necessarily the current
;; generation. /run/current-system might point to
;; /var/guix/profiles/system-N-link, or it might point directly to
;; /gnu/store/…-system. Try both.
- (match (generation-number "/run/current-system" %system-profile)
- (0
- (match (generation-number %system-profile)
- (0
- (leave (G_ "no system generation, nothing to describe~%")))
- (generation
- (display-system-generation generation))))
- (generation
- (display-system-generation generation))))
+ (let ((list-installed-regex (assoc-ref opts 'list-installed)))
+ (match (generation-number "/run/current-system" %system-profile)
+ (0
+ (match (generation-number %system-profile)
+ (0
+ (leave (G_ "no system generation, nothing to describe~%")))
+ (generation
+ (display-system-generation
+ generation #:list-installed-regex list-installed-regex))))
+ (generation
+ (display-system-generation
+ generation #:list-installed-regex list-installed-regex)))))
((search)
(apply (resolve-subcommand "search") args))
((edit)
diff --git a/guix/upstream.scm b/guix/upstream.scm
index dac8153905..cbfd1aa609 100644
--- a/guix/upstream.scm
+++ b/guix/upstream.scm
@@ -251,13 +251,17 @@ correspond to the same version."
#:warn warn-about-load-error)))
(define %updaters
- ;; The list of publically-known updaters.
- (delay (fold-module-public-variables (lambda (obj result)
- (if (upstream-updater? obj)
- (cons obj result)
- result))
- '()
- (importer-modules))))
+ ;; The list of publically-known updaters, alphabetically sorted.
+ (delay
+ (sort (fold-module-public-variables (lambda (obj result)
+ (if (upstream-updater? obj)
+ (cons obj result)
+ result))
+ '()
+ (importer-modules))
+ (lambda (updater1 updater2)
+ (string<? (symbol->string (upstream-updater-name updater1))
+ (symbol->string (upstream-updater-name updater2)))))))
;; Tests need to mock this variable so mark it as "non-declarative".
(set! %updaters %updaters)
@@ -515,9 +519,10 @@ this method: ~s")
#:key-download key-download))))
(values #f #f #f)))
(#f
- (raise (formatted-message
- (G_ "updater failed to determine available releases for ~a~%")
- (package-name package))))))
+ ;; Warn rather than abort so that other updates can still take place.
+ (warning (G_ "updater failed to determine available releases for ~a~%")
+ (package-name package))
+ (values #f #f #f))))
(define* (update-package-source package source hash)
"Modify the source file that defines PACKAGE to refer to SOURCE, an
diff --git a/guix/utils.scm b/guix/utils.scm
index ca4fecebc8..9b277a0092 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -1116,11 +1116,11 @@ according to THRESHOLD, then #f is returned."
;;; Prettified output.
;;;
-(define* (pretty-print-table rows #:key (max-column-width 20))
+(define* (pretty-print-table rows #:key (max-column-width 20) (left-pad 0))
"Print ROWS in neat columns. All rows should be lists of strings and each
row should have the same length. The columns are separated by a tab
character, and aligned using spaces. The maximum width of each column is
-bound by MAX-COLUMN-WIDTH."
+bound by MAX-COLUMN-WIDTH. Each row is prefixed with LEFT-PAD spaces."
(let* ((number-of-columns-to-pad (if (null? rows)
0
(1- (length (first rows)))))
@@ -1135,7 +1135,7 @@ bound by MAX-COLUMN-WIDTH."
(map (cut min <> max-column-width)
column-widths)))
(fmt (string-append (string-join column-formats "\t") "\t~a")))
- (for-each (cut format #t "~?~%" fmt <>) rows)))
+ (for-each (cut format #t "~v_~?~%" left-pad fmt <>) rows)))
;;; Local Variables:
;;; eval: (put 'call-with-progress-reporter 'scheme-indent-function 1)