diff options
| -rw-r--r-- | guix/records.scm | 63 | ||||
| -rw-r--r-- | tests/records.scm | 47 |
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 () |