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:
@@ -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))))))
|
||||
|
||||
|
||||
@@ -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.
|
||||
|
||||
@@ -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) (... ...)))))
|
||||
|
||||
@@ -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
|
||||
|
||||
Reference in New Issue
Block a user