Browse Source

records: Add support for delayed fields.

* guix/records.scm (make-syntactic-constructor): Add #:delayed
  parameter.
  [delayed-field?]: New procedure.
  [wrap-field-value]: Use it.
  (define-record-type*)[delayed-field?, wrapped-field?]: New procedures.
  [thunked-field-accessor-name]: Rename to...
  [wrapped-field-accessor-name]: ... this.
  [field-spec->srfi-9]: Change 'thunked' to 'wrapped'.
  [delayed-field-accessor-definition]: New procedure.
  Compute delayed-field accessors and emit them.  Pass #:delayed to
  'make-syntactic-constructor'.
* tests/records.scm ("define-record-type* & delayed",
  "define-record-type* & delayed & default",
  "define-record-type* & delayed & inherited"): New tests.
gn-latest-20200428
Ludovic Courtès 7 years ago
parent
commit
310b32a2a6
  1. 63
      guix/records.scm
  2. 47
      tests/records.scm

63
guix/records.scm

@ -43,10 +43,12 @@
form))))
(define* (make-syntactic-constructor type name ctor fields
#:key (thunked '()) (defaults '()))
#:key (thunked '()) (defaults '())
(delayed '()))
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects
all of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE
tuples, and THUNKED is the list of identifiers of thunked fields."
tuples, THUNKED is the list of identifiers of thunked fields, and DELAYED is
the list of identifiers of delayed fields."
(with-syntax ((type type)
(name name)
(ctor ctor)
@ -81,10 +83,15 @@ tuples, and THUNKED is the list of identifiers of thunked fields."
(define (thunked-field? f)
(memq (syntax->datum f) '#,thunked))
(define (delayed-field? f)
(memq (syntax->datum f) '#,delayed))
(define (wrap-field-value f value)
(if (thunked-field? f)
#`(lambda () #,value)
value))
(cond ((thunked-field? f)
#`(lambda () #,value))
((delayed-field? f)
#`(delay #,value))
(else value)))
(define (field-bindings field+value)
;; Return field to value bindings, for use in 'let*' below.
@ -161,6 +168,9 @@ The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
actually compute the field's value in the current dynamic extent, which is
useful when referring to fluids in a field's value.
A field can also be marked as \"delayed\" instead of \"thunked\", in which
case its value is effectively wrapped in a (delay ) form.
It is possible to copy an object 'x' created with 'thing' like this:
(thing (inherit x) (name \"bar\"))
@ -176,6 +186,15 @@ field."
(field-default-value #'(field options ...)))
(_ #f)))
(define (delayed-field? s)
;; Return the field name if the field defined by S is delayed.
(syntax-case s (delayed)
((field (delayed) _ ...)
#'field)
((field _ options ...)
(delayed-field? #'(field options ...)))
(_ #f)))
(define (thunked-field? s)
;; Return the field name if the field defined by S is thunked.
(syntax-case s (thunked)
@ -185,9 +204,12 @@ field."
(thunked-field? #'(field options ...)))
(_ #f)))
(define (thunked-field-accessor-name field)
(define (wrapped-field? s)
(or (thunked-field? s) (delayed-field? s)))
(define (wrapped-field-accessor-name field)
;; Return the name (an unhygienic syntax object) of the "real"
;; getter for field, which is assumed to be a thunked field.
;; getter for field, which is assumed to be a wrapped field.
(syntax-case field ()
((field get options ...)
(let* ((getter (syntax->datum #'get))
@ -200,8 +222,8 @@ field."
(syntax-case field ()
((name get options ...)
#`(name
#,(if (thunked-field? field)
(thunked-field-accessor-name field)
#,(if (wrapped-field? field)
(wrapped-field-accessor-name field)
#'get)))))
(define (thunked-field-accessor-definition field)
@ -209,16 +231,27 @@ field."
;; thunked field.
(syntax-case field ()
((name get _ ...)
(with-syntax ((real-get (thunked-field-accessor-name field)))
(with-syntax ((real-get (wrapped-field-accessor-name field)))
#'(define-inlinable (get x)
;; The real value of that field is a thunk, so call it.
((real-get x)))))))
(define (delayed-field-accessor-definition field)
;; Return the real accessor for FIELD, which is assumed to be a
;; delayed field.
(syntax-case field ()
((name get _ ...)
(with-syntax ((real-get (wrapped-field-accessor-name field)))
#'(define-inlinable (get x)
;; The real value of that field is a promise, so force it.
(force (real-get x)))))))
(syntax-case s ()
((_ type syntactic-ctor ctor pred
(field get options ...) ...)
(let* ((field-spec #'((field get options ...) ...))
(thunked (filter-map thunked-field? field-spec))
(delayed (filter-map delayed-field? field-spec))
(defaults (filter-map field-default-value
#'((field options ...) ...))))
(with-syntax (((field-spec* ...)
@ -228,16 +261,24 @@ field."
(and (thunked-field? field)
(thunked-field-accessor-definition
field)))
field-spec))
((delayed-field-accessor ...)
(filter-map (lambda (field)
(and (delayed-field? field)
(delayed-field-accessor-definition
field)))
field-spec)))
#`(begin
(define-record-type type
(ctor field ...)
pred
field-spec* ...)
(begin thunked-field-accessor ...)
(begin thunked-field-accessor ...
delayed-field-accessor ...)
#,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
#'(field ...)
#:thunked thunked
#:delayed delayed
#:defaults defaults))))))))
(define* (alist->record alist make keys

47
tests/records.scm

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -139,6 +139,51 @@
(parameterize ((mark (cons 'a 'b)))
(eq? (foo-baz y) (mark))))))))
(test-assert "define-record-type* & delayed"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar (delayed)))
(let* ((calls 0)
(x (foo (bar (begin (set! calls (1+ calls)) 3)))))
(and (zero? calls)
(equal? (foo-bar x) 3) (= 1 calls)
(equal? (foo-bar x) 3) (= 1 calls)
(equal? (foo-bar x) 3) (= 1 calls)))))
(test-assert "define-record-type* & delayed & default"
(let ((mark #f))
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar (delayed) (default mark)))
(let ((x (foo)))
(set! mark 42)
(and (equal? (foo-bar x) 42)
(begin
(set! mark 7)
(equal? (foo-bar x) 42))))))
(test-assert "define-record-type* & delayed & inherited"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar (delayed))
(baz foo-baz (delayed)))
(let* ((m 1)
(n #f)
(x (foo (bar m) (baz n)))
(y (foo (inherit x) (baz 'b))))
(set! n 'a)
(and (equal? (foo-bar x) 1)
(eq? (foo-baz x) 'a)
(begin
(set! m 777)
(equal? (foo-bar y) 1)) ;promise was already forced
(eq? (foo-baz y) 'b)))))
(test-assert "define-record-type* & missing initializers"
(catch 'syntax-error
(lambda ()

Loading…
Cancel
Save