summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--guix/utils.scm101
-rw-r--r--tests/utils.scm51
2 files changed, 135 insertions, 17 deletions
diff --git a/guix/utils.scm b/guix/utils.scm
index 4d761f590d..7ab835e7f1 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -192,10 +192,11 @@ evaluate to a simple datum."
"Define the given record type such that an additional \"syntactic
constructor\" is defined, which allows instances to be constructed with named
field initializers, à la SRFI-35, as well as default values."
- (define (make-syntactic-constructor type name ctor fields defaults)
+ (define (make-syntactic-constructor type name ctor fields thunked defaults)
"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."
+FIELD/DEFAULT-VALUE tuples, and THUNKED is the list of identifiers of
+thunked fields."
(with-syntax ((type type)
(name name)
(ctor ctor)
@@ -221,10 +222,23 @@ FIELD/DEFAULT-VALUE tuples."
'expected
(iota (length 'expected)))))
+ (define (thunked-field? f)
+ (memq (syntax->datum f) '#,thunked))
+
+ (define (field-bindings field+value)
+ ;; Return field to value bindings, for use in `letrec*' below.
+ (map (lambda (field+value)
+ (syntax-case field+value ()
+ ((field value)
+ #`(field
+ #,(if (thunked-field? #'field)
+ #'(lambda () value)
+ #'value)))))
+ field+value))
(syntax-case s (inherit #,@fields)
((_ (inherit orig-record) (field value) (... ...))
- #`(letrec* ((field value) (... ...))
+ #`(letrec* #,(field-bindings #'((field value) (... ...)))
#,(record-inheritance #'orig-record
#'((field value) (... ...)))))
((_ (field value) (... ...))
@@ -239,7 +253,12 @@ FIELD/DEFAULT-VALUE tuples."
(eq? f (car (syntax->datum x))))
#'((field value) (... ...)))
car)
- (car (assoc-ref dflt (syntax->datum f)))))
+ (let ((value
+ (car (assoc-ref dflt
+ (syntax->datum f)))))
+ (if (thunked-field? f)
+ #`(lambda () #,value)
+ value))))
(let-syntax ((error*
(syntax-rules ()
@@ -250,7 +269,8 @@ FIELD/DEFAULT-VALUE tuples."
s)))))
(let ((fields (append fields (map car dflt))))
(cond ((lset= eq? fields 'expected)
- #`(letrec* ((field value) (... ...))
+ #`(letrec* #,(field-bindings
+ #'((field value) (... ...)))
(ctor #,@(map field-value 'expected))))
((pair? (lset-difference eq? fields 'expected))
(error* "extraneous field initializers ~a"
@@ -268,19 +288,68 @@ FIELD/DEFAULT-VALUE tuples."
(field-default-value #'(field options ...)))
(_ #f)))
+ (define (thunked-field? s)
+ ;; Return the field name if the field defined by S is thunked.
+ (syntax-case s (thunked)
+ ((field (thunked) _ ...)
+ #'field)
+ ((field _ options ...)
+ (thunked-field? #'(field options ...)))
+ (_ #f)))
+
+ (define (thunked-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.
+ (syntax-case field ()
+ ((field get options ...)
+ (let* ((getter (syntax->datum #'get))
+ (real-getter (symbol-append '% getter '-real)))
+ (datum->syntax #'get real-getter)))))
+
+ (define (field-spec->srfi-9 field)
+ ;; Convert a field spec of our style to a SRFI-9 field spec of the
+ ;; form (field get).
+ (syntax-case field ()
+ ((name get options ...)
+ #`(name
+ #,(if (thunked-field? field)
+ (thunked-field-accessor-name field)
+ #'get)))))
+
+ (define (thunked-field-accessor-definition field)
+ ;; Return the real accessor for FIELD, which is assumed to be a
+ ;; thunked field.
+ (syntax-case field ()
+ ((name get _ ...)
+ (with-syntax ((real-get (thunked-field-accessor-name field)))
+ #'(define-inlinable (get x)
+ ;; The real value of that field is a thunk, so call it.
+ ((real-get x)))))))
+
(syntax-case s ()
((_ type syntactic-ctor ctor pred
(field get options ...) ...)
- #`(begin
- (define-record-type type
- (ctor field ...)
- pred
- (field get) ...)
- #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
- #'(field ...)
- (filter-map field-default-value
- #'((field options ...)
- ...))))))))
+ (let* ((field-spec #'((field get options ...) ...)))
+ (with-syntax (((field-spec* ...)
+ (map field-spec->srfi-9 field-spec))
+ ((thunked-field-accessor ...)
+ (filter-map (lambda (field)
+ (and (thunked-field? field)
+ (thunked-field-accessor-definition
+ field)))
+ field-spec)))
+ #`(begin
+ (define-record-type type
+ (ctor field ...)
+ pred
+ field-spec* ...)
+ (begin thunked-field-accessor ...)
+ #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
+ #'(field ...)
+ (filter-map thunked-field? field-spec)
+ (filter-map field-default-value
+ #'((field options ...)
+ ...))))))))))
(define (memoize proc)
"Return a memoizing version of PROC."
diff --git a/tests/utils.scm b/tests/utils.scm
index 59fde5ac06..96496c5f84 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@@ -123,6 +123,55 @@
(match b (($ <foo> 1 2) #t))
(equal? b c)))))
+(test-assert "define-record-type* & thunked"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (thunked)))
+
+ (let* ((calls 0)
+ (x (foo (bar 2)
+ (baz (begin (set! calls (1+ calls)) 3)))))
+ (and (zero? calls)
+ (equal? (foo-bar x) 2)
+ (equal? (foo-baz x) 3) (= 1 calls)
+ (equal? (foo-baz x) 3) (= 2 calls)))))
+
+(test-assert "define-record-type* & thunked & default"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (thunked) (default 42)))
+
+ (let ((mark (make-parameter #f)))
+ (let ((x (foo (bar 2) (baz (mark))))
+ (y (foo (bar 2))))
+ (and (equal? (foo-bar x) 2)
+ (parameterize ((mark (cons 'a 'b)))
+ (eq? (foo-baz x) (mark)))
+ (equal? (foo-bar y) 2)
+ (equal? (foo-baz y) 42))))))
+
+(test-assert "define-record-type* & thunked & inherited"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar (thunked))
+ (baz foo-baz (thunked) (default 42)))
+
+ (let ((mark (make-parameter #f)))
+ (let* ((x (foo (bar 2) (baz (mark))))
+ (y (foo (inherit x) (bar (mark)))))
+ (and (equal? (foo-bar x) 2)
+ (parameterize ((mark (cons 'a 'b)))
+ (eq? (foo-baz x) (mark)))
+ (parameterize ((mark (cons 'a 'b)))
+ (eq? (foo-bar y) (mark)))
+ (parameterize ((mark (cons 'a 'b)))
+ (eq? (foo-baz y) (mark))))))))
+
;; This is actually in (guix store).
(test-equal "store-path-package-name"
"bash-4.2-p24"
generated by cgit v1.2.3 (git 2.46.0) at 2024-11-08 21:36:42 +0000