guix_mirror_bot pushed a commit to branch master
in repository guix.
commit 4a03dc926704fdbb3592a65c7fefe7628e39069d
Author: Nicolas Graves <[email protected]>
AuthorDate: Wed Mar 18 07:55:37 2026 +0100
guix: Refactor (guix build json-utils) from the node build system.
* guix/build/node-build-system.scm
(delete-fields, modify-json, modify-json-fields, replace-fields)
(with-atomic-json-file-replacement, add-fields): Move procedures from
here...
* guix/build/json-utils.scm: ...to this new file.
* guix/build-system/node.scm
(%node-build-system-modules, node-build): Add (guix build json-utils)
module.
* guix/build/tree-sitter-build-system.scm (patch-dependencies): Import
with-atomic-json-file-replacement from (guix build json-utils).
* guix/import/npm-binary.scm: Import (guix build json-utils).
* CODEOWNERS, etc/teams.scm: Add guix/build/json-utils.scm to the
javascript team
scope.
* Makefile.am: Add guix/build/json-utils.scm.
Change-Id: I5264a5265e376902c0a309c0177b7496ac3b6295
Signed-off-by: Jelle Licht <[email protected]>
---
CODEOWNERS | 1 +
Makefile.am | 1 +
etc/teams.scm | 1 +
guix/build-system/node.scm | 2 +
guix/build/json-utils.scm | 164 ++++++++++++++++++++++++++++++++
guix/build/node-build-system.scm | 127 +------------------------
guix/build/tree-sitter-build-system.scm | 3 +-
guix/import/npm-binary.scm | 1 +
8 files changed, 175 insertions(+), 125 deletions(-)
diff --git a/CODEOWNERS b/CODEOWNERS
index 5127f918982..cecb16a75dc 100644
--- a/CODEOWNERS
+++ b/CODEOWNERS
@@ -289,6 +289,7 @@ gnu/packages/javascript\.scm
@guix/javascript
gnu/packages/node-xyz\.scm @guix/javascript
gnu/packages/node\.scm @guix/javascript
guix/build-system/node\.scm @guix/javascript
+guix/build/json-utils\.scm @guix/javascript
guix/build/node-build-system\.scm @guix/javascript
guix/import/npm-binary\.scm @guix/javascript
guix/scripts/import/npm-binary\.scm @guix/javascript
diff --git a/Makefile.am b/Makefile.am
index 804fad7005f..ffc1e89291b 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -268,6 +268,7 @@ MODULES = \
guix/build/vim-build-system.scm \
guix/build/waf-build-system.scm \
guix/build/haskell-build-system.scm \
+ guix/build/json-utils.scm \
guix/build/julia-build-system.scm \
guix/build/kconfig.scm \
guix/build/linux-module-build-system.scm \
diff --git a/etc/teams.scm b/etc/teams.scm
index bc6f8226350..eb3054f4f3b 100755
--- a/etc/teams.scm
+++ b/etc/teams.scm
@@ -910,6 +910,7 @@ and the maven-build-system."
"gnu/packages/node-xyz.scm"
"gnu/packages/node.scm"
"guix/build-system/node.scm"
+ "guix/build/json-utils.scm"
"guix/build/node-build-system.scm"
"guix/import/npm-binary.scm"
"guix/scripts/import/npm-binary.scm")))
diff --git a/guix/build-system/node.scm b/guix/build-system/node.scm
index c07479b693a..596e2cb3e47 100644
--- a/guix/build-system/node.scm
+++ b/guix/build-system/node.scm
@@ -43,6 +43,7 @@
(define %node-build-system-modules
;; Build-side modules imported by default.
`((guix build node-build-system)
+ (guix build json-utils)
,@%default-gnu-imported-modules))
(define (default-node)
@@ -99,6 +100,7 @@
(guile-json (default-guile-json))
(imported-modules %node-build-system-modules)
(modules '((guix build node-build-system)
+ (guix build json-utils)
(guix build utils))))
"Build SOURCE using NODE and INPUTS."
(define builder
diff --git a/guix/build/json-utils.scm b/guix/build/json-utils.scm
new file mode 100644
index 00000000000..f80b1176e4d
--- /dev/null
+++ b/guix/build/json-utils.scm
@@ -0,0 +1,164 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016, 2020 Jelle Licht <[email protected]>
+;;; Copyright © 2019, 2021 Timothy Sample <[email protected]>
+;;; Copyright © 2021, 2022 Philip McGrath <[email protected]>
+;;; Copyright © 2024 Daniel Khodabakhsh <[email protected]>
+;;; Copyright © 2026 Nicolas Graves <[email protected]>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (guix build json-utils)
+ #:use-module (guix build utils)
+ #:use-module (guix deprecation)
+ #:use-module (guix diagnostics)
+ #:use-module (guix i18n)
+ #:use-module (ice-9 format)
+ #:use-module (ice-9 ftw)
+ #:use-module (ice-9 optargs)
+ #:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
+ #:use-module (json)
+ #:use-module (srfi srfi-1)
+ #:export (with-atomic-json-file-replacement
+ modify-json
+ modify-json-fields
+ delete-fields
+ replace-fields
+ add-fields))
+
+;;;
+;;; JSON modification procedures
+;;;
+
+(define* (with-atomic-json-file-replacement proc
+ #:optional (file "package.json"))
+ "Like 'with-atomic-file-replacement', but PROC is called with a single
+argument---the result of parsing FILE's contents as JSON---and should produce
+a value to be written as JSON to the replacement FILE."
+ (with-atomic-file-replacement file
+ (lambda (in out)
+ (scm->json (proc (json->scm in #:ordered #t)) out #:pretty #t))))
+
+(define* (modify-json #:key (file "package.json") #:rest all-arguments)
+ "Provide package.json modifying callbacks such as (delete-dependencies ...)"
+ (let ((modifications
+ (let loop ((arguments all-arguments))
+ (cond
+ ((null? arguments) '())
+ ((keyword? (car arguments)) (loop (cddr arguments)))
+ (else (cons (car arguments) (loop (cdr arguments))))))))
+ (with-atomic-json-file-replacement
+ (lambda (package)
+ (fold (lambda (modification package)
+ (modification package))
+ package
+ modifications))
+ file)))
+
+(define* (modify-json-fields fields field-modifier
+ #:key
+ (field-path-mapper identity)
+ (insert? #f)
+ (strict? #t))
+ "Return a procedure to supply to `modify-json' which modifies the specified
+JSON file. FIELDS is a list procedure-specific data structures which should
+include the definition of a ``field-path'' in one of two syntaxes: dot-syntax
+string such as @code{\"devDependencies.esbuild\"}, or a list of strings such
+as @code{(list \"devDependencies\" \"esbuild\")}.
+
+FIELD-MODIFIER is a procedure called with three arguments: 1) the original
+field-path, e.g. \"dependencies.typescript\", 2) the field's
+surrounding (parent) JSON data, as an association list, and 3) the field
+name (key), e.g. \"typescript\". The value it returns should be the modified
+JSON data associated with the field; in other words, returning the second
+argument without changing it is a no-op.
+
+FIELD-PATH-MAPPER is a procedure which instructs where the field-path is
+located within the field structure. INSERT? allows the creation of the field
+and any missing intermediate fields, while STRICT? causes an error to be
+thrown if the exact field-path is not found in the data."
+ (lambda (package)
+ (fold
+ (lambda (field package)
+ (let* ((field-path (field-path-mapper field))
+ (field-path (cond
+ ((string? field-path)
+ (string-split field-path #\.))
+ ((and (list? field-path) (every string? field-path))
+ field-path)
+ (else (error (format #f "\
+invalid field value provided, expected string or list of strings, got ~s~%"
+ field-path))))))
+ (let loop ((data package)
+ (field-path field-path))
+ (let* ((key (car field-path))
+ (field-missing? (not (assoc key data)))
+ (data (if (and field-missing? insert?)
+ (acons key '() data)
+ data)))
+ (if field-missing?
+ (if strict?
+ (error (format #f "key ~s was not found in data: ~y~%"
+ key data))
+ data)
+ (if (= (length field-path) 1)
+ (field-modifier field data key)
+ (assoc-set! data key
+ (loop (assoc-ref data key)
+ (cdr field-path)))))))))
+ package
+ fields)))
+
+(define* (delete-fields fields #:key (strict? #t))
+ "Provides a lambda to supply to modify-json which deletes the specified
+ `fields` which is a list of field-paths as mentioned in `modify-json-fields`.
+ Examples:
+ (delete-fields '(
+ (\"path\" \"to\" \"field\")
+ \"path.to.other.field\"))"
+ (modify-json-fields
+ fields
+ (lambda (_ data key)
+ (format #t "deleting field ~s, of value: ~y~%"
+ key (assoc-ref data key))
+ (assoc-remove! data key))
+ #:strict? strict?))
+
+(define* (replace-fields fields #:key (strict? #t) insert?)
+ "Provides a lambda to supply to modify-json which replaces the value of the
+ supplied field. `fields` is a list of pairs, where the first element is the
+ field-path and the second element is the value to replace the target with.
+ Examples:
+ (replace-fields '(
+ ((\"path\" \"to\" \"field\") \"new field value\")
+ (\"path.to.other.field\" \"new field value\")))"
+ (modify-json-fields
+ fields
+ (lambda (field data key)
+ (let ((value (cdr field)))
+ (format #t "setting field ~s to value: ~y~%" key value)
+ (assoc-set! data key value)))
+ #:field-path-mapper (lambda (field) (car field))
+ #:insert? insert?
+ #:strict? strict?))
+
+(define* (add-fields fields)
+ "Like `replace-fields', but can insert new fields as well."
+ (replace-fields fields #:insert? #t))
+
+;;; Local Variables:
+;;; eval: (put 'with-atomic-json-file-replacement 'scheme-indent-function 1)
+;;; End:
diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm
index 08623f97756..00384da2d41 100644
--- a/guix/build/node-build-system.scm
+++ b/guix/build/node-build-system.scm
@@ -25,6 +25,7 @@
(define-module (guix build node-build-system)
#:use-module ((guix build gnu-build-system) #:prefix gnu:)
+ #:use-module (guix build json-utils)
#:use-module (guix build utils)
#:use-module (ice-9 format)
#:use-module (ice-9 ftw)
@@ -39,43 +40,12 @@
delete-dependencies/except
delete-dev-dependencies
delete-dev-dependencies/except
- delete-fields
- add-fields
- modify-json
- modify-json-fields
- node-build
- replace-fields
- with-atomic-json-file-replacement))
+ node-build))
;;;
-;;; package.json modification procedures
+;;; Helpers
;;;
-(define* (with-atomic-json-file-replacement proc
- #:optional (file "package.json"))
- "Like 'with-atomic-file-replacement', but PROC is called with a single
-argument---the result of parsing FILE's contents as JSON---and should produce
-a value to be written as JSON to the replacement FILE."
- (with-atomic-file-replacement file
- (lambda (in out)
- (scm->json (proc (json->scm in #:ordered #t)) out #:pretty #t))))
-
-(define* (modify-json #:key (file "package.json") #:rest all-arguments)
- "Provide package.json modifying callbacks such as (delete-dependencies ...)"
- (let ((modifications
- (let loop ((arguments all-arguments))
- (cond
- ((null? arguments) '())
- ((keyword? (car arguments)) (loop (cddr arguments)))
- (else (cons (car arguments) (loop (cdr arguments))))))))
- (with-atomic-json-file-replacement
- (lambda (package)
- (fold (lambda (modification package)
- (modification package))
- package
- modifications))
- file)))
-
(define %dependency-keys
'("devDependencies"
"dependencies"
@@ -125,97 +95,6 @@ dependencies."
(delete-dependencies/except dependencies-to-preserve
#:dependency-keys %dev-dependency-keys))
-(define* (modify-json-fields fields field-modifier
- #:key
- (field-path-mapper identity)
- (insert? #f)
- (strict? #t))
- "Return a procedure to supply to `modify-json' which modifies the specified
-JSON file. FIELDS is a list procedure-specific data structures which should
-include the definition of a ``field-path'' in one of two syntaxes: dot-syntax
-string such as @code{\"devDependencies.esbuild\"}, or a list of strings such
-as @code{(list \"devDependencies\" \"esbuild\")}.
-
-FIELD-MODIFIER is a procedure called with three arguments: 1) the original
-field-path, e.g. \"dependencies.typescript\", 2) the field's
-surrounding (parent) JSON data, as an association list, and 3) the field
-name (key), e.g. \"typescript\". The value it returns should be the modified
-JSON data associated with the field; in other words, returning the second
-argument without changing it is a no-op.
-
-FIELD-PATH-MAPPER is a procedure which instructs where the field-path is
-located within the field structure. INSERT? allows the creation of the field
-and any missing intermediate fields, while STRICT? causes an error to be
-thrown if the exact field-path is not found in the data."
- (lambda (package)
- (fold
- (lambda (field package)
- (let* ((field-path (field-path-mapper field))
- (field-path (cond
- ((string? field-path)
- (string-split field-path #\.))
- ((and (list? field-path) (every string? field-path))
- field-path)
- (else (error (format #f "\
-invalid field value provided, expected string or list of strings, got ~s~%"
- field-path))))))
- (let loop ((data package)
- (field-path field-path))
- (let* ((key (car field-path))
- (field-missing? (not (assoc key data)))
- (data (if (and field-missing? insert?)
- (acons key '() data)
- data)))
- (if field-missing?
- (if strict?
- (error (format #f "key ~s was not found in data: ~y~%"
- key data))
- data)
- (if (= (length field-path) 1)
- (field-modifier field data key)
- (assoc-set! data key
- (loop (assoc-ref data key)
- (cdr field-path)))))))))
- package
- fields)))
-
-(define* (delete-fields fields #:key (strict? #t))
- "Provides a lambda to supply to modify-json which deletes the specified
- `fields` which is a list of field-paths as mentioned in `modify-json-fields`.
- Examples:
- (delete-fields '(
- (\"path\" \"to\" \"field\")
- \"path.to.other.field\"))"
- (modify-json-fields
- fields
- (lambda (_ data key)
- (format #t "deleting field ~s, of value: ~y~%"
- key (assoc-ref data key))
- (assoc-remove! data key))
- #:strict? strict?))
-
-(define* (replace-fields fields #:key (strict? #t) insert?)
- "Provides a lambda to supply to modify-json which replaces the value of the
- supplied field. `fields` is a list of pairs, where the first element is the
- field-path and the second element is the value to replace the target with.
- Examples:
- (replace-fields '(
- ((\"path\" \"to\" \"field\") \"new field value\")
- (\"path.to.other.field\" \"new field value\")))"
- (modify-json-fields
- fields
- (lambda (field data key)
- (let ((value (cdr field)))
- (format #t "setting field ~s to value: ~y~%" key value)
- (assoc-set! data key value)))
- #:field-path-mapper (lambda (field) (car field))
- #:insert? insert?
- #:strict? strict?))
-
-(define* (add-fields fields)
- "Like `replace-fields', but can insert new fields as well."
- (replace-fields fields #:insert? #t))
-
(define (delete-dev-dependencies)
(delete-fields (list "devDependencies" "peerDependencies")
#:strict? #f))
diff --git a/guix/build/tree-sitter-build-system.scm
b/guix/build/tree-sitter-build-system.scm
index 5819594f063..f19fc5f43cb 100644
--- a/guix/build/tree-sitter-build-system.scm
+++ b/guix/build/tree-sitter-build-system.scm
@@ -19,6 +19,7 @@
(define-module (guix build tree-sitter-build-system)
#:use-module ((guix build node-build-system) #:prefix node:)
+ #:use-module (guix build json-utils)
#:use-module (guix build utils)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
@@ -48,7 +49,7 @@
"Rewrite dependencies in 'package.json'. We remove all runtime dependencies
and replace development dependencies with tree-sitter grammar node modules."
- (node:with-atomic-json-file-replacement
+ (with-atomic-json-file-replacement "package.json"
(lambda (pkg-meta-alist)
(map (match-lambda
(("dependencies" dependencies ...)
diff --git a/guix/import/npm-binary.scm b/guix/import/npm-binary.scm
index 2cbd23ed022..333adaab552 100644
--- a/guix/import/npm-binary.scm
+++ b/guix/import/npm-binary.scm
@@ -25,6 +25,7 @@
#:use-module (gcrypt hash)
#:use-module (gnu packages)
#:use-module (guix base32)
+ #:use-module (guix build json-utils)
#:use-module (guix http-client)
#:use-module ((guix import git) #:select (get-tags))
#:use-module (guix import json)
