[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#55499: [PATCH 3/3] squash! profiles: Make all entry fields optional.
From: |
Ludovic Courtès |
Subject: |
bug#55499: [PATCH 3/3] squash! profiles: Make all entry fields optional. |
Date: |
Tue, 31 May 2022 18:09:16 +0200 |
This is meant to be squashed with the previous patch.
This makes the 'search-paths' and 'propagated-inputs' fields of each
entry optional, shaving a bit more space and reading time, down to 180K
instead of 192K.
* guix/build/profiles.scm (manifest-sexp->inputs+search-paths)[let-fields]:
New macro.
Use it.
* guix/profiles.scm (manifest->gexp)[optional]: New procedure. Use it.
[sexp->manifest-entry]: Rename to...
[sexp->manifest-entry/v3]: ... this.
---
guix/build/profiles.scm | 28 ++++++++--
guix/profiles.scm | 120 ++++++++++++++++++++++++++--------------
2 files changed, 100 insertions(+), 48 deletions(-)
diff --git a/guix/build/profiles.scm b/guix/build/profiles.scm
index c4460f624b..2ab76bde74 100644
--- a/guix/build/profiles.scm
+++ b/guix/build/profiles.scm
@@ -149,6 +149,18 @@ (define (manifest-sexp->inputs+search-paths manifest)
"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 4)
('packages (entries ...)))
@@ -156,12 +168,12 @@ (define (manifest-sexp->inputs+search-paths manifest)
(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 properties)
+ (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))
(()
@@ -214,4 +226,8 @@ (define manifest-file
;; 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/profiles.scm b/guix/profiles.scm
index 44ff37e75b..d694ac07da 100644
--- a/guix/profiles.scm
+++ b/guix/profiles.scm
@@ -454,6 +454,11 @@ (define (inferior->entry)
(define (manifest->gexp manifest)
"Return a representation of MANIFEST as a gexp."
+ (define (optional name value)
+ (if (null? value)
+ #~()
+ #~((#$name #$value))))
+
(define (entry->gexp entry)
;; Maintain in state monad a vhash of visited entries, indexed by their
;; item, usually package objects (we cannot use the entry itself as an
@@ -477,24 +482,22 @@ (define (entry->gexp entry)
(return
(match entry
(($ <manifest-entry> name version output (? string? path)
- (_deps ...) (search-paths ...) _
(properties ...))
+ (_ ...) (search-paths ...) _ (properties
...))
#~(#$name #$version #$output #$path
- (propagated-inputs #$deps)
- (search-paths #$(map
search-path-specification->sexp
- search-paths))
- #$@(if (null? properties)
- #~()
- #~((properties . #$properties)))))
+ #$@(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"))
- (propagated-inputs #$deps)
- (search-paths #$(map
search-path-specification->sexp
- search-paths))
- #$@(if (null? properties)
- #~()
- #~((properties . #$properties))))))))))))
+ #$@(optional 'propagated-inputs deps)
+ #$@(optional 'search-paths
+ (map search-path-specification->sexp
+ search-paths))
+ #$@(optional 'properties properties))))))))))
(match manifest
(($ <manifest> (entries ...))
@@ -542,6 +545,40 @@ (define (infer-dependency item parent)
(item item)
(parent parent))))
+ (define* (sexp->manifest-entry/v3 sexp #:optional (parent (delay #f)))
+ (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/v3 <> (delay entry))
+ deps))
+ (entry (manifest-entry
+ (name name)
+ (version version)
+ (output output)
+ (item path)
+ (dependencies deps*)
+ (search-paths (map sexp->search-path-specification
+ search-paths))
+ (parent parent)
+ (properties (or (assoc-ref extra-stuff 'properties)
+ '())))))
+ 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)
@@ -556,32 +593,29 @@ (define* (sexp->manifest-entry sexp #:optional (parent
(delay #f)))
sexp)))
((_ . entry)
(return entry)))))
- ((name version output path
- ('propagated-inputs deps)
- ('search-paths search-paths)
- extra-stuff ...)
- (mlet* %state-monad
- ((entry -> #f)
- (deps* (mapm %state-monad
- (cut sexp->manifest-entry <> (delay entry))
- deps))
- (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 (or (assoc-ref extra-stuff 'properties)
- '()))))
- (mbegin %state-monad
- (set-current-state (vhash-cons key entry visited))
- (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)
@@ -649,9 +683,7 @@ (define* (sexp->manifest-entry sexp #:optional (parent
(delay #f)))
;; Version 3 represents DEPS as full-blown manifest entries.
(('manifest ('version 3 minor-version ...)
('packages (entries ...)))
- (manifest (run-with-state
- (mapm %state-monad sexp->manifest-entry entries)
- vlist-null)))
+ (manifest (map sexp->manifest-entry/v3 entries)))
;; Version 4 deduplicates repeated entries, as can happen with deep
;; propagated input trees.
@@ -2368,4 +2400,8 @@ (define (user-friendly-profile profile)
%known-shorthand-profiles)
profile))
+;;; Local Variables:
+;;; eval: (put 'let-fields 'scheme-indent-function 2)
+;;; End:
+
;;; profiles.scm ends here
--
2.36.1