Subject: [PATCH 3/3] squash! profiles: Make all entry fields optional.

From: Ludovic Courtès <[email-masked]>
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