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.
This commit is contained in:
Ludovic Courtès
parent
0db40ed289
commit
310b32a2a6
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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…
Reference in New Issue