diff options
| -rw-r--r-- | guix/utils.scm | 101 | ||||
| -rw-r--r-- | tests/utils.scm | 51 |
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" |