projects/guix·blob javascript-team · refs

310 lines · 10.4 KiB

1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2026 Nicolas Graves <[email protected]>
3;;; Copyright © 2026 Maxim Cournoyer <[email protected]>
4;;;
5;;; This file is part of GNU Guix.
6;;;
7;;; GNU Guix is free software; you can redistribute it and/or modify it
8;;; under the terms of the GNU General Public License as published by
9;;; the Free Software Foundation; either version 3 of the License, or (at
10;;; your option) any later version.
11;;;
12;;; GNU Guix is distributed in the hope that it will be useful, but
13;;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15;;; GNU General Public License for more details.
16;;;
17;;; You should have received a copy of the GNU General Public License
18;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19
20(define-module (test-json-utils)
21 #:use-module (guix build json-utils)
22 #:use-module (guix tests)
23 #:use-module (json)
24 #:use-module (srfi srfi-26)
25 #:use-module (srfi srfi-64))
26
27(define sample-json
28 '(("name" . "my-package")
29 ("version" . "1.0.0")
30 ("dependencies" . (("foo" . "^1.0.0")
31 ("bar" . "^2.0.0")))
32 ("devDependencies" . (("baz" . "^3.0.0")
33 ("qux" . "^4.0.0")))
34 ("scripts" . (("build" . "make build")
35 ("test" . "make test")))))
36
37;; Many json-utils procedures use assoc-set! and assoc-remove! which
38;; mutate alist structure in place. Use copy-tree to obtain a fresh
39;; deep copy for each test.
40(define (fresh-sample-json)
41 (copy-tree sample-json))
42
43(define (package.json)
44 "Sample package.json file as a JSON string."
45 (call-with-output-string
46 (cute scm->json sample-json <> #:pretty #t)))
47
48(define (with-atomic-file-replacement/mock _ proc)
49 "Mock for with-atomic-file-replacement: reads from package.json procedure,
50captures the written output as a string."
51 (call-with-input-string (package.json)
52 (lambda (in)
53 (call-with-output-string
54 (cute proc in <>)))))
55
56(define* (modify-json* #:rest all-arguments)
57 "Mock modify-json* with input from the package.json procedure."
58 (mock ((guix build utils) with-atomic-file-replacement
59 with-atomic-file-replacement/mock)
60 (json-string->scm (apply modify-json all-arguments)
61 #:ordered #t)))
62
63(test-begin "json-utils")
64
65;;;
66;;; with-atomic-json-file-replacement
67;;;
68
69(test-equal "with-atomic-json-file-replacement, modify top-level field"
70 "2.0.0"
71 (assoc-ref
72 (modify-json* (cut assoc-set! <> "version" "2.0.0"))
73 "version"))
74
75;;;
76;;; delete-json-fields
77;;;
78
79(test-assert "delete-json-fields, single top-level field"
80 (let ((result ((delete-json-fields '("version")) (fresh-sample-json))))
81 (and (not (assoc-ref result "version"))
82 (assoc-ref result "name"))))
83
84(test-assert "delete-json-fields, multiple top-level fields"
85 (let ((result ((delete-json-fields '("version" "name")) (fresh-sample-json))))
86 (and (not (assoc-ref result "version"))
87 (not (assoc-ref result "name"))
88 (assoc-ref result "dependencies"))))
89
90(test-assert "delete-json-fields, nested field with dot syntax"
91 (let ((result ((delete-json-fields '("dependencies.foo")) (fresh-sample-json))))
92 (and (not (assoc-ref (assoc-ref result "dependencies") "foo"))
93 (assoc-ref (assoc-ref result "dependencies") "bar"))))
94
95(test-assert "delete-json-fields, nested field with list syntax"
96 (let ((result ((delete-json-fields '(("dependencies" "bar")))
97 (fresh-sample-json))))
98 (and (not (assoc-ref (assoc-ref result "dependencies") "bar"))
99 (assoc-ref (assoc-ref result "dependencies") "foo"))))
100
101(test-assert "delete-json-fields, missing field with strict? #f"
102 (let ((result ((delete-json-fields '("nonexistent") #:strict? #f)
103 (fresh-sample-json))))
104 (assoc-ref result "name")))
105
106(test-error "delete-json-fields, missing field with strict? #t raises error"
107 &modify-json-missing-key-error
108 ((delete-json-fields '("nonexistent") #:strict? #t) (fresh-sample-json)))
109
110(test-assert "delete-json-fields, missing nested field with strict? #f"
111 (let ((result ((delete-json-fields '("dependencies.nonexistent")
112 #:strict? #f)
113 (fresh-sample-json))))
114 (assoc-ref (assoc-ref result "dependencies") "foo")))
115
116;;;
117;;; replace-json-fields
118;;;
119
120(test-equal "replace-json-fields, single top-level field"
121 "new-name"
122 (assoc-ref
123 ((replace-json-fields '(("name" . "new-name"))) (fresh-sample-json))
124 "name"))
125
126(test-equal "replace-json-fields, nested field with dot syntax"
127 "^5.0.0"
128 (assoc-ref
129 (assoc-ref
130 ((replace-json-fields '(("dependencies.foo" . "^5.0.0")))
131 (fresh-sample-json))
132 "dependencies")
133 "foo"))
134
135(test-equal "replace-json-fields, nested field with list syntax"
136 "^6.0.0"
137 (assoc-ref
138 (assoc-ref
139 ((replace-json-fields '((("dependencies" "bar") . "^6.0.0")))
140 (fresh-sample-json))
141 "dependencies")
142 "bar"))
143
144(test-equal "replace-json-fields, multiple replacements"
145 '("new-name" . "2.0.0")
146 (let ((result ((replace-json-fields
147 '(("name" . "new-name")
148 ("version" . "2.0.0")))
149 (fresh-sample-json))))
150 (cons (assoc-ref result "name")
151 (assoc-ref result "version"))))
152
153(test-error "replace-json-fields, missing field with strict? #t raises error"
154 &modify-json-missing-key-error
155 ((replace-json-fields '(("nonexistent" . "value")) #:strict? #t)
156 (fresh-sample-json)))
157
158(test-assert "replace-json-fields, missing field with strict? #f"
159 (let ((result ((replace-json-fields '(("nonexistent" . "value"))
160 #:strict? #f)
161 (fresh-sample-json))))
162 (equal? (assoc-ref result "name") "my-package")))
163
164;;;
165;;; add-json-fields
166;;;
167(test-equal "add-json-fields"
168 #("test")
169 (assoc-ref (modify-json*
170 (add-json-fields '(("exclude" . #("test")))))
171 "exclude"))
172
173(test-equal "add-json-fields, recursive"
174 "^25.9.2"
175 (assoc-ref (assoc-ref (modify-json*
176 (add-json-fields '(("devDependencies2.@types/node"
177 . "^25.9.2"))))
178 "devDependencies2")
179 "@types/node"))
180
181(test-equal "add-json-fields, recursive, partially preexisting"
182 "^9.9.9"
183 (assoc-ref (assoc-ref (modify-json*
184 (add-json-fields '(("devDependencies.@types/dummy"
185 . "^9.9.9"))))
186 "devDependencies")
187 "@types/dummy"))
188
189(test-error "add-json-fields, preexisting field"
190 &modify-json-preexisting-key-error
191 (modify-json* (add-json-fields '(("name" . "duplicate")))))
192
193(test-error "add-json-fields, preexisting multi-level field"
194 &modify-json-preexisting-key-error
195 (modify-json* (add-json-fields '(("devDependencies.qux"
196 . "^9.0.0")))))
197
198;;;
199;;; modify-json-fields
200;;;
201
202(test-equal "modify-json-fields, custom modifier on top-level field"
203 "MY-PACKAGE"
204 (assoc-ref
205 ((modify-json-fields '("name")
206 (lambda (field data key)
207 (assoc-set! data key (string-upcase (assoc-ref data key)))))
208 (fresh-sample-json))
209 "name"))
210
211(test-equal "modify-json-fields, custom modifier on nested field"
212 "^1.0.0-patched"
213 (assoc-ref
214 (assoc-ref
215 ((modify-json-fields '("dependencies.foo")
216 (lambda (field data key)
217 (assoc-set! data key
218 (string-append (assoc-ref data key) "-patched"))))
219 (fresh-sample-json))
220 "dependencies")
221 "foo"))
222
223(test-assert "modify-json-fields, insert? creates missing field"
224 (let ((result ((modify-json-fields '("newField")
225 (lambda (field data key)
226 (assoc-set! data key "inserted"))
227 #:insert? #t)
228 (fresh-sample-json))))
229 (equal? (assoc-ref result "newField") "inserted")))
230
231(test-assert "modify-json-fields, insert? creates nested missing fields"
232 (let ((result ((modify-json-fields '("newSection.newKey")
233 (lambda (field data key)
234 (assoc-set! data key "deep-insert"))
235 #:insert? #t)
236 (fresh-sample-json))))
237 (equal? (assoc-ref (assoc-ref result "newSection") "newKey")
238 "deep-insert")))
239
240(test-assert "modify-json-fields, field-path-mapper"
241 (let ((result ((modify-json-fields '(("name" . "REPLACED"))
242 (lambda (field data key)
243 (assoc-set! data key (cdr field)))
244 #:field-path-mapper car)
245 (fresh-sample-json))))
246 (equal? (assoc-ref result "name") "REPLACED")))
247
248(test-error "modify-json-fields, invalid field-path raises error"
249 &modify-json-invalid-field-value-error
250 ((modify-json-fields '(42) (lambda (field data key) data))
251 (fresh-sample-json)))
252
253(test-equal "modify-json, ordering"
254 '(("baz" . "^3.0.0")
255 ("qux" . "^4.0.0"))
256 (assoc-ref (modify-json* (modify-json-fields
257 '("devDependencies.qux")
258 (lambda (field-path data key)
259 data))) ;no-op
260 "devDependencies"))
261
262;;;
263;;; modify-json (deprecated wrapper)
264;;;
265
266(test-equal "modify-json, single modification"
267 "modified"
268 (assoc-ref
269 (modify-json* (cut assoc-set! <> "name" "modified"))
270 "name"))
271
272(test-equal "modify-json, chained modifications"
273 '("chain-name" . "3.0.0")
274 (let ((result (modify-json*
275 (cut assoc-set! <> "name" "chain-name")
276 (cut assoc-set! <> "version" "3.0.0"))))
277 (cons (assoc-ref result "name")
278 (assoc-ref result "version"))))
279
280;;;
281;;; Integration: delete-json-fields and replace-json-fields with modify-json
282;;;
283
284(test-equal "modify-json + delete-json-fields integration"
285 #f
286 (assoc-ref
287 (modify-json* (delete-json-fields '("devDependencies")))
288 "devDependencies"))
289
290(test-equal "modify-json + replace-json-fields integration"
291 "^9.0.0"
292 (assoc-ref
293 (assoc-ref
294 (modify-json* (replace-json-fields '(("dependencies.foo" . "^9.0.0"))))
295 "dependencies")
296 "foo"))
297
298(test-equal "modify-json + chained delete and replace integration"
299 '(#f . "replaced-name")
300 (let ((result (modify-json*
301 (delete-json-fields '("devDependencies"))
302 (replace-json-fields '(("name" . "replaced-name"))))))
303 (cons (assoc-ref result "devDependencies")
304 (assoc-ref result "name"))))
305
306(test-end "json-utils")
307
308;; Local Variables:
309;; eval: (put 'modify-json-fields 'scheme-indent-function 1)
310;; End: