summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--guix/records.scm63
-rw-r--r--tests/records.scm47
2 files changed, 98 insertions, 12 deletions
diff --git a/guix/records.scm b/guix/records.scm
index 8a4d6a7bb6..fd17e135e1 100644
--- a/guix/records.scm
+++ b/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
diff --git a/tests/records.scm b/tests/records.scm
index e90d33d15d..a00e38db7d 100644
--- a/tests/records.scm
+++ b/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 ()