summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--doc/guix-cookbook.texi2
-rw-r--r--doc/guix.texi13
-rw-r--r--guix/records.scm69
-rw-r--r--tests/records.scm66
4 files changed, 131 insertions, 19 deletions
diff --git a/doc/guix-cookbook.texi b/doc/guix-cookbook.texi
index 4b6f0ca22c0..83bce66c175 100644
--- a/doc/guix-cookbook.texi
+++ b/doc/guix-cookbook.texi
@@ -5297,7 +5297,7 @@ did above with transformation options. We can add them like so:
5297 "Return P with FLAGS as additional 'configure' flags." 5297 "Return P with FLAGS as additional 'configure' flags."
5298 (package/inherit p 5298 (package/inherit p
5299 (arguments 5299 (arguments
5300 (substitute-keyword-arguments (package-arguments p) 5300 (substitute-keyword-arguments arguments
5301 ((#:configure-flags original-flags #~(list)) 5301 ((#:configure-flags original-flags #~(list))
5302 #~(append #$original-flags #$flags)))))) 5302 #~(append #$original-flags #$flags))))))
5303 5303
diff --git a/doc/guix.texi b/doc/guix.texi
index e7bcd174a8e..d5f782f35c4 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -8800,14 +8800,15 @@ dependency like so:
8800(define gdb-sans-guile 8800(define gdb-sans-guile
8801 (package 8801 (package
8802 (inherit gdb) 8802 (inherit gdb)
8803 (inputs (modify-inputs (package-inputs gdb) 8803 (inputs (modify-inputs inputs
8804 (delete "guile"))))) 8804 (delete "guile")))))
8805@end lisp 8805@end lisp
8806 8806
8807The @code{modify-inputs} form above removes the @code{"guile"} package 8807In the body of the @code{inputs} field above, @code{inputs} is bound to
8808from the @code{inputs} field of @code{gdb}. The @code{modify-inputs} 8808the inherited value. Thus, the @code{modify-inputs} form above removes
8809macro is a helper that can prove useful anytime you want to remove, add, 8809the @code{"guile"} package from the @code{inputs} field of @code{gdb}.
8810or replace package inputs. 8810The @code{modify-inputs} macro is a helper that can prove useful anytime
8811you want to remove, add, or replace package inputs.
8811 8812
8812@defmac modify-inputs inputs clauses 8813@defmac modify-inputs inputs clauses
8813Modify the given package inputs, as returned by @code{package-inputs} & co., 8814Modify the given package inputs, as returned by @code{package-inputs} & co.,
@@ -9131,7 +9132,7 @@ these lines:
9131(define gdb-sans-guile 9132(define gdb-sans-guile
9132 (package 9133 (package
9133 (inherit gdb) 9134 (inherit gdb)
9134 (inputs (modify-inputs (package-inputs gdb) 9135 (inputs (modify-inputs inputs
9135 (delete "guile"))))) 9136 (delete "guile")))))
9136 9137
9137;; Return a manifest containing that one package plus Git. 9138;; Return a manifest containing that one package plus Git.
diff --git a/guix/records.scm b/guix/records.scm
index 261f6f07b6c..bf746d3b5d9 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -1,5 +1,5 @@
1;;; GNU Guix --- Functional package management for GNU 1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012-2025 Ludovic Courtès <ludo@gnu.org> 2;;; Copyright © 2012-2026 Ludovic Courtès <ludo@gnu.org>
3;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> 3;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
4;;; 4;;;
5;;; This file is part of GNU Guix. 5;;; This file is part of GNU Guix.
@@ -192,18 +192,55 @@ of TYPE matches the expansion-time ABI."
192 (or (and=> (assoc-ref lst (syntax->datum f)) car) 192 (or (and=> (assoc-ref lst (syntax->datum f)) car)
193 #'(lambda (x) x))))) 193 #'(lambda (x) x)))))
194 194
195 (define (wrap-field-value f value) 195 (define (field-index f)
196 ;; Return the index of F within the record.
197 (let ((f (syntax->datum f)))
198 (let loop ((fields '(expected ...))
199 (index 0))
200 (match fields
201 (()
202 ;; Internal error.
203 (record-error 'name s "field not found ~a" f))
204 ((head . rest)
205 (if (eq? f head)
206 index
207 (loop rest (+ 1 index))))))))
208
209 (define* (wrap-field-value f value #:optional parent)
210 ;; Wrap VALUE, the value of field F, such that its sanitizer is
211 ;; called and its properties (thunked, delayed) honored. When
212 ;; PARENT is true, bind F to the value inherited from PARENT in the
213 ;; lexical scope of VALUE.
196 (let* ((sanitizer (field-sanitizer f)) 214 (let* ((sanitizer (field-sanitizer f))
197 (value #`(#,sanitizer #,value))) 215 (value #`(#,sanitizer #,value)))
198 (cond ((thunked-field? f) 216 (cond ((thunked-field? f)
199 #`(lambda (x) 217 (if parent
200 (syntax-parameterize ((#,this-identifier 218 ;; Compute the value being inherited by calling the
201 (lambda (s) 219 ;; thunked field F of PARENT with a self-reference for
202 (syntax-case s () 220 ;; the new record being constructed.
203 (id 221 (with-syntax ((inherited
204 (identifier? #'id) 222 #`((struct-ref #,parent
205 #'x))))) 223 #,(field-index f))
206 #,value))) 224 #,this-identifier)))
225 #`(lambda (x)
226 (syntax-parameterize ((#,this-identifier
227 (lambda (s)
228 (syntax-case s ()
229 (id
230 (identifier? #'id)
231 #'x)))))
232 ;; Bind F, the field identifier, to the value
233 ;; being inherited.
234 (let-syntax ((#,f (identifier-syntax inherited)))
235 #,value))))
236 #`(lambda (x)
237 (syntax-parameterize ((#,this-identifier
238 (lambda (s)
239 (syntax-case s ()
240 (id
241 (identifier? #'id)
242 #'x)))))
243 #,value))))
207 ((delayed-field? f) 244 ((delayed-field? f)
208 #`(delay #,value)) 245 #`(delay #,value))
209 (else value)))) 246 (else value))))
@@ -227,9 +264,19 @@ of TYPE matches the expansion-time ABI."
227 #,(wrap-field-value #'field #'value))))) 264 #,(wrap-field-value #'field #'value)))))
228 field+value)) 265 field+value))
229 266
267 (define (field-bindings/inheritance parent field+value)
268 ;; Return field to value bindings, for use in 'let*' below.
269 (map (lambda (field+value)
270 (syntax-case field+value ()
271 ((field value)
272 #`(field
273 #,(wrap-field-value #'field #'value parent)))))
274 field+value))
275
230 (syntax-case s (inherit expected ...) 276 (syntax-case s (inherit expected ...)
231 ((_ (inherit orig-record) (field value) (... ...)) 277 ((_ (inherit orig-record) (field value) (... ...))
232 #`(let* #,(field-bindings #'((field value) (... ...))) 278 #`(let* #,(field-bindings/inheritance #'orig-record
279 #'((field value) (... ...)))
233 #,(abi-check #'type abi-cookie) 280 #,(abi-check #'type abi-cookie)
234 #,(record-inheritance #'orig-record 281 #,(record-inheritance #'orig-record
235 #'((field value) (... ...))))) 282 #'((field value) (... ...)))))
diff --git a/tests/records.scm b/tests/records.scm
index 5464892d3b5..9c071334d50 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -1,5 +1,5 @@
1;;; GNU Guix --- Functional package management for GNU 1;;; GNU Guix --- Functional package management for GNU
2;;; Copyright © 2012-2016, 2018-2022 Ludovic Courtès <ludo@gnu.org> 2;;; Copyright © 2012-2016, 2018-2022, 2026 Ludovic Courtès <ludo@gnu.org>
3;;; 3;;;
4;;; This file is part of GNU Guix. 4;;; This file is part of GNU Guix.
5;;; 5;;;
@@ -238,6 +238,70 @@
238 (bar? first) 238 (bar? first)
239 (eq? first y))))))) 239 (eq? first y)))))))
240 240
241(test-equal "define-record-type* & thunked & no inherited value"
242 '(baz) ;the unbound variable
243 (catch 'unbound-variable
244 (lambda ()
245 (eval '(begin
246 (define-record-type* <foo> foo make-foo
247 foo?
248 (bar foo-bar)
249 (baz foo-baz (thunked)))
250
251 ;; There's no inheritance here so 'baz' is unbound in the field
252 ;; body. Call 'foo-baz' to trigger to unbound variable error.
253 (foo-baz (foo (bar 1) (baz baz))))
254 (test-module)))
255 (lambda (key proc message arguments . rest)
256 arguments)))
257
258(test-equal "define-record-type* & thunked & inherited value"
259 '(1 22)
260 (begin
261 (define-record-type* <foo> foo make-foo
262 foo?
263 (bar foo-bar)
264 (baz foo-baz (thunked)))
265
266 (let* ((parent (foo (bar 1) (baz 2)))
267 (child (foo (inherit parent)
268 (baz (* baz 11)))))
269 (list (foo-bar child) (foo-baz child)))))
270
271(test-equal "define-record-type* & thunked & inherited value & this-record"
272 '((1 2) => (21 (inherited . 42)))
273 (begin
274 (define-record-type* <foo> foo make-foo
275 foo?
276 (bar foo-bar)
277 (baz foo-baz (thunked)))
278
279 (let* ((parent (foo (bar 1)
280 (baz (* 2 (foo-bar this-record)))))
281 (child (foo (inherit parent)
282 (bar 21)
283 (baz (cons 'inherited baz)))))
284 `((,(foo-bar parent) ,(foo-baz parent))
285 =>
286 (,(foo-bar child) ,(foo-baz child))))))
287
288(test-equal "define-record-type* & thunked & inherited value & sanitizer"
289 '((1 "2") => (4 "88"))
290 (begin
291 (define-record-type* <foo> foo make-foo
292 foo?
293 (bar foo-bar)
294 (baz foo-baz (thunked) (sanitize number->string)))
295
296 (let* ((parent (foo (bar 1)
297 (baz (* 2 (foo-bar this-record)))))
298 (child (foo (inherit parent)
299 (bar 4)
300 (baz (+ 80 (string->number baz))))))
301 `((,(foo-bar parent) ,(foo-baz parent))
302 =>
303 (,(foo-bar child) ,(foo-baz child))))))
304
241(test-assert "define-record-type* & delayed" 305(test-assert "define-record-type* & delayed"
242 (begin 306 (begin
243 (define-record-type* <foo> foo make-foo 307 (define-record-type* <foo> foo make-foo