diff options
| -rw-r--r-- | doc/guix-cookbook.texi | 2 | ||||
| -rw-r--r-- | doc/guix.texi | 13 | ||||
| -rw-r--r-- | guix/records.scm | 69 | ||||
| -rw-r--r-- | tests/records.scm | 66 |
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 | ||
| 8807 | The @code{modify-inputs} form above removes the @code{"guile"} package | 8807 | In the body of the @code{inputs} field above, @code{inputs} is bound to |
| 8808 | from the @code{inputs} field of @code{gdb}. The @code{modify-inputs} | 8808 | the inherited value. Thus, the @code{modify-inputs} form above removes |
| 8809 | macro is a helper that can prove useful anytime you want to remove, add, | 8809 | the @code{"guile"} package from the @code{inputs} field of @code{gdb}. |
| 8810 | or replace package inputs. | 8810 | The @code{modify-inputs} macro is a helper that can prove useful anytime |
| 8811 | you want to remove, add, or replace package inputs. | ||
| 8811 | 8812 | ||
| 8812 | @defmac modify-inputs inputs clauses | 8813 | @defmac modify-inputs inputs clauses |
| 8813 | Modify the given package inputs, as returned by @code{package-inputs} & co., | 8814 | Modify 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 |
