define-record-type*: Add the `thunked' field definition keyword.

* guix/utils.scm (define-record-type*)[make-syntactic-constructor]: Add
  a `thunked' parameter.
  (thunked-field?, field-bindings): New procedures.  Use the latter when
  generating `letrec*' bindings.
  [thunked-field?, thunked-field-accessor-name, field-spec->srfi-9,
  thunked-field-accessor-name]: New procedures.
  Use them when generating the `define-record-type' form, and to
  generated thunk field accessors, along call to
  `make-syntactic-constructor' with the new argument.
* tests/utils.scm ("define-record-type* & thunked",
  "define-record-type* & thunked & default",
  "define-record-type* & thunked & inherited"): New tests.

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"