[bug#51838] [PATCH v2 05/26] guix: node-build-system: Add #:absent-dependencies argument.

[Philip McGrath]

Many of Guix's Node.js packages are built without some of the
dependencies they specify in their "package-lock.json" files,
either because we don't have them packaged yet (e.g. test
utilities) or because we don't want them (e.g. to reduce the
closure size). Previously, Guix package definitions would work
around this situation by deleting the `'configure`
phase (i.e. the initial `npm install`).

This commit adds an optional #:absent-dependencies argument to
`node-build-system` to list Node.js packages that should be
removed from the "package.json" file.Retaining the `'configure`
phase avoids skipping checks for the dependencies that are
intended to be present and other actions performed by `npm
install`, such as automatically building native add-ons with
`node-gyp` when the "gypfile" key is present.

* guix/build-system/node.scm (lower, node-build): Add optional
argument #:absent-dependencies with default of ''(). Pass it on
to the build-side code.
* guix/build/node-build-system.scm (patch-dependencies): Respect
the #:absent-dependencies argument, removing specified npm
packages from the "dependencies" or "devDependencies" tables
in "package.json". Also, strictly follow the linearity rules
for `assoc-set!` and friends.
---
 guix/build-system/node.scm       |  3 ++
 guix/build/node-build-system.scm | 55 ++++++++++++++++++++++----------
 2 files changed, 41 insertions(+), 17 deletions(-)

diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm
index 98f63f87ef..75ae34508f 100644
--- a/guix/build-system/node.scm
+++ b/guix/build-system/node.scm
@@ -44,6 +44,7 @@ (define (default-node)
 (define* (lower name
                 #:key source inputs native-inputs outputs system target
                 (node (default-node))
+                (absent-dependencies ''())
                 #:allow-other-keys
                 #:rest arguments)
   "Return a bag for NAME."
@@ -73,6 +74,7 @@ (define* (node-build store name inputs
                      (tests? #t)
                      (phases '(@ (guix build node-build-system)
                                  %standard-phases))
+                     (absent-dependencies ''())
                      (outputs '("out"))
                      (search-paths '())
                      (system (%current-system))
@@ -94,6 +96,7 @@ (define builder
                    #:test-target ,test-target
                    #:tests? ,tests?
                    #:phases ,phases
+                   #:absent-dependencies ,absent-dependencies
                    #:outputs %outputs
                    #:search-paths ',(map search-path-specification->sexp
                                          search-paths)
diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm
index 70a367618e..32d6807e3e 100644
--- a/guix/build/node-build-system.scm
+++ b/guix/build/node-build-system.scm
@@ -69,30 +69,51 @@ (define (list-modules directory)
               input-paths)
     index))
 
-(define* (patch-dependencies #:key inputs #:allow-other-keys)
+(define* (patch-dependencies #:key inputs absent-dependencies
+                             #:allow-other-keys)
 
   (define index (index-modules (map cdr inputs)))
 
-  (define (resolve-dependencies package-meta meta-key)
-    (fold (lambda (key+value acc)
-            (match key+value
-              ('@ acc)
-              ((key . value) (acons key (hash-ref index key value) acc))))
+  (define (resolve-dependencies meta-alist meta-key)
+    (match (assoc-ref meta-alist meta-key)
+      (#f
+       '())
+      (('@ . orig-deps)
+       (fold (match-lambda*
+               (('@ acc)
+                acc)
+                (((key . value) acc)
+                 (if (member key absent-dependencies)
+                     acc
+                     (acons key (hash-ref index key value) acc))))
           '()
-          (or (assoc-ref package-meta meta-key) '())))
+          orig-deps))))
 
   (with-atomic-file-replacement "package.json"
     (lambda (in out)
-      (let ((package-meta (read-json in)))
-        (assoc-set! package-meta "dependencies"
-                    (append
-                     '(@)
-                     (resolve-dependencies package-meta "dependencies")
-                     (resolve-dependencies package-meta "peerDependencies")))
-        (assoc-set! package-meta "devDependencies"
-                    (append
-                     '(@)
-                     (resolve-dependencies package-meta "devDependencies")))
+      ;; It is unsafe to rely on 'assoc-set!' to update an
+      ;; existing assosciation list variable:
+      ;; see 'info "(guile)Adding or Setting Alist Entries"'.
+      (let* ((package-meta (read-json in))
+             (alist (match package-meta
+                      ((@ . alist) alist)))
+             ;; Other relevant keys may include peerDependenciesMeta
+             ;; and optionalDependencies, but it seems to work out fine
+             ;; just to leave those alone.
+             (alist
+              (assoc-set!
+               alist "dependencies"
+               (append
+                '(@)
+                (resolve-dependencies alist "dependencies")
+                (resolve-dependencies alist "peerDependencies"))))
+             (alist
+              (assoc-set!
+               alist "devDependencies"
+               (append
+                '(@)
+                (resolve-dependencies alist "devDependencies"))))
+             (package-meta (cons '@ alist)))
         (write-json package-meta out))))
   #t)
 
-- 
2.32.0