[bug#51838] [PATCH v6 03/41] guix: node-build-system: Add JSON utilities.

[Philip McGrath <philip@philipmcgrath.com>]

This commit adds several utility functions for non-destructive
transformation of the JSON representation used by (guix build json),
particularly for purely functional update of JSON objects.  They should
eventually be exported, but most are private for now to allow for more
experience and consideration before commiting to the API.  The design
was largely inspired by the 'racket/dict' and 'racket/hash' libraries.
Liliana Marie Prikler proposed 'with-atomic-json-file-replacement'.

* guix/build/node-build-system.scm (jsobject-ref):
(alist-pop):
(alist-delete*):
(jsobject-delete):
(alist-set):
(jsobject-set):
(jsobject-set*):
(alist-update):
(jsobject-update):
(jsobject-update*):
(jsobject-union): New private procedures.
(with-atomic-json-file-replacement): New exported procedure.
(module-name): Use them.
(build): Use them.
(patch-dependencies): Use them.  Stop using 'assoc-set!' unsafely.

Co-authored-by: Liliana Marie Prikler <liliana.prikler@gmail.com>
---
 guix/build/node-build-system.scm | 275 ++++++++++++++++++++++++++++---
 1 file changed, 251 insertions(+), 24 deletions(-)

diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm
index dcaa719f40..e5c4da5091 100644
--- a/guix/build/node-build-system.scm
+++ b/guix/build/node-build-system.scm
@@ -26,6 +26,7 @@ (define-module (guix build node-build-system)
   #:use-module (ice-9 match)
   #:use-module (srfi srfi-1)
   #:export (%standard-phases
+            with-atomic-json-file-replacement
             node-build))
 
 ;; Commentary:
@@ -34,6 +35,237 @@ (define-module (guix build node-build-system)
 ;;
 ;; Code:
 
+;;;
+;;; JSON utilities.
+;;;
+;;; The following procedures facilitate transforming JSON values using the
+;;; representation from (guix build json), particularly purely functional
+;;; update of JSON objects.  If we decide to make more of them public, we
+;;; might instead put them in their own file or, eventually, add them to
+;;; (guix build json).
+;;;
+;;; JSON objects with duplicate keys are not interoperable: see RFC 8259 § 4.
+;;; These procedures assume, but generally do not check, that JSON objects
+;;; given to them as arguments do not have duplicate keys.  As long as that
+;;; precondition is satisfied, they will produce JSON objects without
+;;; duplicate keys.  Procedures that operate on unwrapped assosciation lists
+;;; may do likewise, which should be considered before exporting them for
+;;; general use.
+;;;
+
+(define (with-atomic-json-file-replacement file proc)
+  "Like 'with-atomic-file-replacement', but PROC is called with a single
+argument---the result of parsing FILE's contents as json---and should a value
+to be written as json to the replacement FILE."
+  (with-atomic-file-replacement file
+    (lambda (in out)
+      (write-json (proc (read-json in)) out))))
+
+(define (jsobject-ref js key failure-result)
+  "Return the value assosciated with KEY in the json object JS.  If KEY is not
+found and FAILURE-RESULT is a procedure, it is called in tail position with
+zero arguments.  Otherwise, FAILURE-RESULT is returned."
+  ;; TODO: `failure-result` should be optional, but should the default
+  ;; `failure-result` be #f (like `assoc-ref`), a thunk raising an exception,
+  ;; '(@), or something else?  Keep it mandatory until we discuss and decide.
+  (match js
+    (('@ . alist)
+     (match (assoc key alist)
+       (#f
+        (if (procedure? failure-result)
+            (failure-result)
+            failure-result))
+       ((_ . value)
+        value)))))
+
+(define (alist-pop alist key)
+  "Return two values: the first pair in ALIST with the given KEY in its
+'car' (or #f, if no such pair exists) and an assosciation list like (and
+potentially sharing storage with) ALIST, but with no entry for KEY."
+  (match (assoc key alist)
+    ;; If key isn't present, we don't need to do any allocation
+    (#f
+     (values #f alist))
+    (found
+     (values found
+             ;; Because we have `found`, we can find it more
+             ;; efficiently this time with `eq?`. We avoid using
+             ;; `delq` because it would copy pairs in a shared
+             ;; tail. We assume a sufficiently smart compiler to
+             ;; handle "tail recursion modulo cons" (vid. e.g. Indiana
+             ;; University Technical Report No. 19, Friedman & Wise
+             ;; 1975) at least as efficiently as a hand-written
+             ;; tail-recursive implementation with an accumulator.
+             (let loop ((alist alist))
+               (match alist
+                 ;; We know that `found` is present,
+                 ;; so no need to check for '()
+                 ((this . alist)
+                  (if (eq? this found)
+                      alist
+                      (cons this (loop alist))))))))))
+
+;; Sadly, Guile's implementation of (@ (srfi srfi-1) alist-delete)
+;; performs unnecessary allocation, e.g. this currently evaluates to #f:
+;;
+;;     (let ((alist `(("a" . 1)("b" . 2)("c" . 3))))
+;;       (eq? alist (alist-delete "x" alist)))
+;;
+;; These functions generally choose to allocate a new outer pair (with the '@
+;; tag), even though in unusual cases the resulting object might not have
+;; changed, for the sake of simplicity and to avoid retaining a reference to
+;; the original alist longer than necessary. But that is O(1) allocation that
+;; could only rarely be avoided: `alist-delete` would allocate O(n) pairs,
+;; which would only be necessary in the worst case.
+(define (alist-delete* alist key)
+  "Return an assosciation list like (and potentially sharing storage with)
+ALIST, but with no entry for KEY."
+  (define-values (_popped remaining)
+    (alist-pop alist key))
+  remaining)
+
+(define (jsobject-delete js key)
+  "Return a json object like JS, but with no entry for KEY."
+  (cons '@ (match js
+             (('@ . alist)
+              (alist-delete* alist key)))))
+
+(define (alist-set alist key value)
+  "Return an assosciation list like ALIST, but with KEY mapped to VALUE,
+replacing any existing mapping for KEY."
+  (acons key value (alist-delete* alist key)))
+
+(define (jsobject-set js key value)
+  "Return a json object like JS, but with KEY mapped to VALUE, replacing any
+existing mapping for KEY."
+  (cons '@ (match js
+             (('@ . alist)
+              (alist-set alist key value)))))
+
+(define jsobject-set*
+  (case-lambda
+    "Return a json object like JS, but functionally extended by mapping each
+KEY to each VALUE, replacing any existing mapping for each KEY.  The update
+takes place from left to right, so later mappings overwrite earlier mappings
+for the same KEY."
+    ((js)
+     js)
+    ((js key value)
+     (jsobject-set js key value))
+    ((js . args)
+     (cons '@ (match js
+                (('@ . alist)
+                 (let loop ((alist alist)
+                            (args args))
+                   (match args
+                     (()
+                     alist)
+                     ((key value . args)
+                      (loop (alist-set alist key value)
+                            args))))))))))
+
+(define (alist-update alist key failure-result updater)
+  "Return an assosciation list like ALIST, but with KEY mapped to the result
+of applying UPDATER to the value to which KEY is mapped in ALIST.  When ALIST
+does not have an existing mapping for KEY, FAILURE-RESULT is used as with
+'jsobject-ref' to obtain the argument for UPDATER."
+  ;; Often, `updater` will be a lambda expression, so making it the last
+  ;; argument may help to makes the code legible, and the most likely
+  ;; `failure-result` arguments are all shorter than the keyword
+  ;; `#:failure-result`.  Plus, making `failure-result` mandatory helps make
+  ;; `alist-update` consistent with `alist-update*`.
+  (define-values (popped tail-alist)
+    (alist-pop alist key))
+  (acons key
+         (updater (match popped
+                    (#f
+                     (if (procedure? failure-result)
+                         (failure-result)
+                         failure-result))
+                    ((_ . value)
+                     value)))
+         tail-alist))
+
+(define (jsobject-update js key failure-result updater)
+  "Return a json object like JS, but with KEY mapped to the result of applying
+UPDATER to the value to which KEY is mapped in JS.  When JS does not have an
+existing mapping for KEY, FAILURE-RESULT is used as with 'jsobject-ref' to
+obtain the argument for UPDATER."
+  (cons '@ (match js
+             (('@ . alist)
+              (alist-update alist key failure-result updater)))))
+
+(define jsobject-update*
+  (case-lambda
+    "Return a json object like JS, but functionally extended by replacing the
+mapping for each KEY with the result of applying the corresponding UPDATER to
+the value to which that KEY is mapped in JS---or, if no such mapping exists,
+to a value based on the corresponding FAILURE-RESULT as with 'jsobject-ref'.
+The update takes place from left to right, so later UPDATERs will receive the
+values returned by earlier UPDATERs for the same KEY."
+    ((js)
+     js)
+    ((js key failure-result updater)
+     (jsobject-update js key failure-result updater))
+    ((js . args)
+     (cons '@ (match js
+                (('@ . alist)
+                 (let loop ((alist alist)
+                            (args args))
+                   (match args
+                     (()
+                     alist)
+                     ((key failure-result updater . args)
+                      (loop (alist-update alist key failure-result updater)
+                            args))))))))))
+
+(define* (jsobject-union #:key
+                         (combine (lambda (a b) b))
+                         (combine/key (lambda (k a b) (combine a b)))
+                         #:rest json-objects)
+  "Combine the given JSON-OBJECTS into a single json object.  The JSON-OBJECTS
+are merged from left to right by adding each key/value pair of each object to
+the aggregate object in turn.  When one of the JSON-OBJECTS contains a mapping
+from some key KEY to a value VAL such that the aggregate object already
+contains a mapping from KEY to a value VAL0, the aggregate object is
+functionally updated to instead map KEY to the value of (COMBINE/KEY KEY VAL0
+VAL).  The default COMBINE/KEY tail-calls (COMBINE VAL0 VAL), and the default
+COMBINE simply returns its second argument, so, by default, mappings in later
+JSON-OBJECTS supersede those in earlier ones."
+  (match (filter (lambda (v)
+                   (not (or (keyword? v)
+                            (procedure? v))))
+                 json-objects)
+    (()
+     '(@))
+    (((and js0 ('@ . _)))
+     js0)
+    ((('@ . alist0) ('@ . alist*) ...)
+     (cons '@ (fold (lambda (alist1 alist0)
+                      (if (null? alist0)
+                          alist1
+                          (fold (lambda (k+v alist0)
+                                  (match k+v
+                                    ((k . v)
+                                     (define-values (popped tail-alist)
+                                       (alist-pop alist0 k))
+                                     (match popped
+                                       (#f
+                                        (cons k+v tail-alist))
+                                       ((_ . v0)
+                                        (acons k
+                                               (combine/key k v0 v)
+                                               tail-alist))))))
+                                alist0
+                                alist1)))
+                    alist0
+                    alist*)))))
+
+\f
+;;;
+;;; Phases.
+;;;
+
 (define (set-home . _)
   (with-directory-excursion ".."
     (let loop ((i 0))
@@ -49,7 +281,7 @@ (define (set-home . _)
 (define (module-name module)
   (let* ((package.json (string-append module "/package.json"))
          (package-meta (call-with-input-file package.json read-json)))
-    (assoc-ref package-meta "name")))
+    (jsobject-ref package-meta "name" #f)))
 
 (define (index-modules input-paths)
   (define (list-modules directory)
@@ -73,27 +305,24 @@ (define* (patch-dependencies #:key inputs #: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))))
-          '()
-          (or (assoc-ref package-meta meta-key) '())))
+  (define resolve-dependencies
+    (match-lambda
+      (('@ . alist)
+       (cons '@ (map (match-lambda
+                       ((key . value)
+                        (cons key (hash-ref index key value))))
+                     alist)))))
 
-  (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")))
-        (write-json package-meta out))))
+  (with-atomic-json-file-replacement "package.json"
+    (lambda (pkg-meta)
+      (jsobject-update*
+       pkg-meta
+       "devDependencies" '(@) resolve-dependencies
+       "dependencies" '(@) (lambda (deps)
+                             (resolve-dependencies
+                              (jsobject-union
+                               (jsobject-ref pkg-meta "peerDependencies" '(@))
+                               deps))))))
   #t)
 
 (define* (delete-lockfiles #:key inputs #:allow-other-keys)
@@ -114,9 +343,7 @@ (define* (configure #:key outputs inputs #:allow-other-keys)
 
 (define* (build #:key inputs #:allow-other-keys)
   (let ((package-meta (call-with-input-file "package.json" read-json)))
-    (if (and=> (assoc-ref package-meta "scripts")
-               (lambda (scripts)
-                 (assoc-ref scripts "build")))
+    (if (jsobject-ref (jsobject-ref package-meta "scripts" '(@)) "build" #f)
         (let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
           (invoke npm "run" "build"))
         (format #t "there is no build script to run~%"))
-- 
2.32.0