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 ought
to eventually be exported from their own module, but for now are kept
private to allow experimentation.
* guix/build/node-build-system.scm (assoc-ref*, jsobject-ref, alist-pop)
(alist-update, jsobject-update*, jsobject-union): New variables.
(with-atomic-json-file-replacement): New public variable.
(module-name, build, patch-dependencies): Use them. Do not resort to
unsafe alist primitives from Guile core.
Co-authored-by: Liliana Marie Prikler <liliana.prikler@gmail.com>
---
guix/build/node-build-system.scm | 145 ++++++++++++++++++++++++-------
1 file changed, 115 insertions(+), 30 deletions(-)
diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm
index 2d7a3bdc67..c6602b876b 100644
--- a/guix/build/node-build-system.scm
+++ b/guix/build/node-build-system.scm
@@ -3,6 +3,7 @@
;;; Copyright © 2016, 2020 Jelle Licht <jlicht@fsfe.org>
;;; Copyright © 2019, 2021 Timothy Sample <samplet@ngyro.com>
;;; Copyright © 2021 Philip McGrath <philip@philipmcgrath.com>
+;;; Copyright © 2021 Liliana Marie Prikler <liliana.prikler@gmail.com>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -26,14 +27,101 @@ (define-module (guix build node-build-system)
#:use-module (ice-9 ftw)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-71)
#:export (%standard-phases
+ with-atomic-json-file-replacement
node-build))
-;; Commentary:
-;;
-;; Builder-side code of the standard Node/NPM package install procedure.
-;;
-;; Code:
+(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* (assoc-ref* alist key #:optional default)
+ "Like assoc-ref, but return DEFAULT instead of #f if no value exists."
+ (match (assoc key alist)
+ (#f default)
+ ((_ . value) value)))
+
+(define* (jsobject-ref obj key #:optional default)
+ (match obj
+ (('@ . alist) (assoc-ref* alist key default))))
+
+(define* (alist-pop alist key #:optional (= equal?))
+ "Return two values, the first pair in ALIST with key KEY, and the other
+elements. Equality calls are made as (= KEY ALISTCAR)."
+ (define (found? pair)
+ (= key (car pair)))
+
+ (let ((before after (break found? alist)))
+ (if (pair? after)
+ (values (car after) (append before (cdr after)))
+ (values #f before))))
+
+(define* (alist-update alist key proc #:optional default (= equal?))
+ "Return an association list like ALIST, but with KEY mapped to the result of
+PROC applied to the first value found under the comparison (= KEY ALISTCAR).
+If no such value exists, use DEFAULT instead.
+Unlike acons, this removes the previous association of KEY (assuming it is
+unique), but the result may still share storage with ALIST."
+ (let ((pair rest (alist-pop alist key =)))
+ (acons key
+ (proc (if (pair? pair)
+ (cdr pair)
+ default))
+ rest)))
+
+(define (jsobject-update* js . updates)
+ "Return a json object like JS, but with all UPDATES applied. Each update
+is a list (KEY PROC [DEFAULT]), so that KEY is mapped to the result of
+PROC applied to the value found for it, or DEFAULT otherwise."
+ (match js
+ (('@ . alist)
+ (let loop ((alist alist)
+ (updates updates))
+ (match updates
+ (() (cons '@ alist))
+ (((key proc) . updates)
+ (loop (alist-update alist key proc #f equal?) updates))
+ (((key proc default) . updates)
+ (loop (alist-update alist key proc default equal?) updates)))))))