1
0
mirror of https://git.savannah.gnu.org/git/guix.git synced 2026-04-06 13:10:33 +02:00

records: Let thunked fields refer to their inherited value.

* guix/records.scm (make-syntactic-constructor)[field-index]: New procedure.
[wrap-field-value]: Add optional argument ‘parent’.  When it is true, bind F
to the inherited field value.
[field-bindings/inheritance]: New procedure.
Use it.
* tests/records.scm ("define-record-type* & thunked & no inherited value")
("define-record-type* & thunked & inherited value")
("define-record-type* & thunked & inherited value & this-record"): New tests.
* doc/guix.texi (Defining Package Variants): Update ‘modify-inputs’ example to
refer to ‘inputs’.
(Writing Manifests): Likewise.
* doc/guix-cookbook.texi (Package Variants): Likewise for
‘substitute-keyword-arguments’.

Fixes: https://issues.guix.gnu.org/50335
Change-Id: If4e18155ce203637ff9e116ee8098f8997bfebe2
This commit is contained in:
Ludovic Courtès
2026-03-06 18:46:35 +01:00
parent e1457c4679
commit a7c8e68dc5
4 changed files with 131 additions and 19 deletions

View File

@@ -5297,7 +5297,7 @@ did above with transformation options. We can add them like so:
"Return P with FLAGS as additional 'configure' flags."
(package/inherit p
(arguments
(substitute-keyword-arguments (package-arguments p)
(substitute-keyword-arguments arguments
((#:configure-flags original-flags #~(list))
#~(append #$original-flags #$flags))))))

View File

@@ -8800,14 +8800,15 @@ dependency like so:
(define gdb-sans-guile
(package
(inherit gdb)
(inputs (modify-inputs (package-inputs gdb)
(inputs (modify-inputs inputs
(delete "guile")))))
@end lisp
The @code{modify-inputs} form above removes the @code{"guile"} package
from the @code{inputs} field of @code{gdb}. The @code{modify-inputs}
macro is a helper that can prove useful anytime you want to remove, add,
or replace package inputs.
In the body of the @code{inputs} field above, @code{inputs} is bound to
the inherited value. Thus, the @code{modify-inputs} form above removes
the @code{"guile"} package from the @code{inputs} field of @code{gdb}.
The @code{modify-inputs} macro is a helper that can prove useful anytime
you want to remove, add, or replace package inputs.
@defmac modify-inputs inputs clauses
Modify the given package inputs, as returned by @code{package-inputs} & co.,
@@ -9131,7 +9132,7 @@ these lines:
(define gdb-sans-guile
(package
(inherit gdb)
(inputs (modify-inputs (package-inputs gdb)
(inputs (modify-inputs inputs
(delete "guile")))))
;; Return a manifest containing that one package plus Git.

View File

@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012-2025 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012-2026 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
;;;
;;; This file is part of GNU Guix.
@@ -192,10 +192,36 @@ of TYPE matches the expansion-time ABI."
(or (and=> (assoc-ref lst (syntax->datum f)) car)
#'(lambda (x) x)))))
(define (wrap-field-value f value)
(define (field-index f)
;; Return the index of F within the record.
(let ((f (syntax->datum f)))
(let loop ((fields '(expected ...))
(index 0))
(match fields
(()
;; Internal error.
(record-error 'name s "field not found ~a" f))
((head . rest)
(if (eq? f head)
index
(loop rest (+ 1 index))))))))
(define* (wrap-field-value f value #:optional parent)
;; Wrap VALUE, the value of field F, such that its sanitizer is
;; called and its properties (thunked, delayed) honored. When
;; PARENT is true, bind F to the value inherited from PARENT in the
;; lexical scope of VALUE.
(let* ((sanitizer (field-sanitizer f))
(value #`(#,sanitizer #,value)))
(cond ((thunked-field? f)
(if parent
;; Compute the value being inherited by calling the
;; thunked field F of PARENT with a self-reference for
;; the new record being constructed.
(with-syntax ((inherited
#`((struct-ref #,parent
#,(field-index f))
#,this-identifier)))
#`(lambda (x)
(syntax-parameterize ((#,this-identifier
(lambda (s)
@@ -203,7 +229,18 @@ of TYPE matches the expansion-time ABI."
(id
(identifier? #'id)
#'x)))))
#,value)))
;; Bind F, the field identifier, to the value
;; being inherited.
(let-syntax ((#,f (identifier-syntax inherited)))
#,value))))
#`(lambda (x)
(syntax-parameterize ((#,this-identifier
(lambda (s)
(syntax-case s ()
(id
(identifier? #'id)
#'x)))))
#,value))))
((delayed-field? f)
#`(delay #,value))
(else value))))
@@ -227,9 +264,19 @@ of TYPE matches the expansion-time ABI."
#,(wrap-field-value #'field #'value)))))
field+value))
(define (field-bindings/inheritance parent field+value)
;; Return field to value bindings, for use in 'let*' below.
(map (lambda (field+value)
(syntax-case field+value ()
((field value)
#`(field
#,(wrap-field-value #'field #'value parent)))))
field+value))
(syntax-case s (inherit expected ...)
((_ (inherit orig-record) (field value) (... ...))
#`(let* #,(field-bindings #'((field value) (... ...)))
#`(let* #,(field-bindings/inheritance #'orig-record
#'((field value) (... ...)))
#,(abi-check #'type abi-cookie)
#,(record-inheritance #'orig-record
#'((field value) (... ...)))))

View File

@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012-2016, 2018-2022 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012-2016, 2018-2022, 2026 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -238,6 +238,70 @@
(bar? first)
(eq? first y)))))))
(test-equal "define-record-type* & thunked & no inherited value"
'(baz) ;the unbound variable
(catch 'unbound-variable
(lambda ()
(eval '(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar)
(baz foo-baz (thunked)))
;; There's no inheritance here so 'baz' is unbound in the field
;; body. Call 'foo-baz' to trigger to unbound variable error.
(foo-baz (foo (bar 1) (baz baz))))
(test-module)))
(lambda (key proc message arguments . rest)
arguments)))
(test-equal "define-record-type* & thunked & inherited value"
'(1 22)
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar)
(baz foo-baz (thunked)))
(let* ((parent (foo (bar 1) (baz 2)))
(child (foo (inherit parent)
(baz (* baz 11)))))
(list (foo-bar child) (foo-baz child)))))
(test-equal "define-record-type* & thunked & inherited value & this-record"
'((1 2) => (21 (inherited . 42)))
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar)
(baz foo-baz (thunked)))
(let* ((parent (foo (bar 1)
(baz (* 2 (foo-bar this-record)))))
(child (foo (inherit parent)
(bar 21)
(baz (cons 'inherited baz)))))
`((,(foo-bar parent) ,(foo-baz parent))
=>
(,(foo-bar child) ,(foo-baz child))))))
(test-equal "define-record-type* & thunked & inherited value & sanitizer"
'((1 "2") => (4 "88"))
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar)
(baz foo-baz (thunked) (sanitize number->string)))
(let* ((parent (foo (bar 1)
(baz (* 2 (foo-bar this-record)))))
(child (foo (inherit parent)
(bar 4)
(baz (+ 80 (string->number baz))))))
`((,(foo-bar parent) ,(foo-baz parent))
=>
(,(foo-bar child) ,(foo-baz child))))))
(test-assert "define-record-type* & delayed"
(begin
(define-record-type* <foo> foo make-foo