08/08: records: Add support for delayed fields.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 310b32a2a6136a99d3c48542bf68d0d8b550f42f
Author: Ludovic Courtès <address@hidden>
Date:   Mon Jan 19 23:21:47 2015 +0100

    records: Add support for delayed fields.
    
    * guix/records.scm (make-syntactic-constructor): Add #:delayed
      parameter.
      [delayed-field?]: New procedure.
      [wrap-field-value]: Use it.
      (define-record-type*)[delayed-field?, wrapped-field?]: New procedures.
      [thunked-field-accessor-name]: Rename to...
      [wrapped-field-accessor-name]: ... this.
      [field-spec->srfi-9]: Change 'thunked' to 'wrapped'.
      [delayed-field-accessor-definition]: New procedure.
      Compute delayed-field accessors and emit them.  Pass #:delayed to
      'make-syntactic-constructor'.
    * tests/records.scm ("define-record-type* & delayed",
      "define-record-type* & delayed & default",
      "define-record-type* & delayed & inherited"): New tests.
---
 guix/records.scm  |   63 +++++++++++++++++++++++++++++++++++++++++++---------
 tests/records.scm |   47 ++++++++++++++++++++++++++++++++++++++-
 2 files changed, 98 insertions(+), 12 deletions(-)

diff --git a/guix/records.scm b/guix/records.scm
index 8a4d6a7..fd17e13 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 e90d33d..a00e38d 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 <address@hidden>
+;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <address@hidden>
 ;;;
 ;;; 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 ()