From d2be7e3c4ba8d6d0dde9b4c0bff623ab85637424 Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Fri, 29 Mar 2019 22:40:55 +0100
Subject: records: Support custom 'this' identifiers.

This lets record users choose an identifier other than 'this-record'.

* guix/records.scm (make-syntactic-constructor): Add #:this-identifier.
[wrap-field-value]: Honor it.
(define-record-type*): Add form with extra THIS-IDENTIFIER and honor
it.
* tests/records.scm ("define-record-type* & thunked & inherit & custom this"):
New test.
---
 guix/records.scm  | 32 +++++++++++++++++++++++++++++---
 tests/records.scm | 18 ++++++++++++++++++
 2 files changed, 47 insertions(+), 3 deletions(-)

diff --git a/guix/records.scm b/guix/records.scm
index 244b124098..99507dc384 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -118,6 +118,7 @@ of TYPE matches the expansion-time ABI."
     ((_ type name ctor (expected ...)
         #:abi-cookie abi-cookie
         #:thunked thunked
+        #:this-identifier this-identifier
         #:delayed delayed
         #:innate innate
         #:defaults defaults)
@@ -162,7 +163,7 @@ of TYPE matches the expansion-time ABI."
          (define (wrap-field-value f value)
            (cond ((thunked-field? f)
                   #`(lambda (x)
-                      (syntax-parameterize ((this-record
+                      (syntax-parameterize ((#,this-identifier
                                              (lambda (s)
                                                (syntax-case s ()
                                                  (id
@@ -254,6 +255,7 @@ may look like this:
 
   (define-record-type* <thing> thing make-thing
     thing?
+    this-thing
     (name  thing-name (default \"chbouib\"))
     (port  thing-port
            (default (current-output-port)) (thunked))
@@ -273,7 +275,8 @@ default value specified in the 'define-record-type*' form is used:
 
 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.
+useful when referring to fluids in a field's value.  Furthermore, that thunk
+can access the record it belongs to via the 'this-thing' identifier.
 
 A field can also be marked as \"delayed\" instead of \"thunked\", in which
 case its value is effectively wrapped in a (delay …) form.
@@ -352,7 +355,9 @@ inherited."
 
     (syntax-case s ()
       ((_ type syntactic-ctor ctor pred
+          this-identifier
           (field get properties ...) ...)
+       (identifier? #'this-identifier)
        (let* ((field-spec #'((field get properties ...) ...))
               (thunked    (filter-map thunked-field? field-spec))
               (delayed    (filter-map delayed-field? field-spec))
@@ -381,15 +386,36 @@ inherited."
                  field-spec* ...)
                (define #,(current-abi-identifier #'type)
                  #,cookie)
+
+               #,@(if (free-identifier=? #'this-identifier #'this-record)
+                      #'()
+                      #'((define-syntax-parameter this-identifier
+                           (lambda (s)
+                             "Return the record being defined.  This macro may
+only be used in the context of the definition of a thunked field."
+                             (syntax-case s ()
+                               (id
+                                (identifier? #'id)
+                                (syntax-violation 'this-identifier
+                                                  "cannot be used outside \
+of a record instantiation"
+                                                  #'id)))))))
                thunked-field-accessor ...
                delayed-field-accessor ...
                (make-syntactic-constructor type syntactic-ctor ctor
                                            (field ...)
                                            #:abi-cookie #,cookie
                                            #:thunked #,thunked
+                                           #:this-identifier #'this-identifier
                                            #:delayed #,delayed
                                            #:innate #,innate
-                                           #:defaults #,defaults))))))))
+                                           #:defaults #,defaults)))))
+      ((_ type syntactic-ctor ctor pred
+          (field get properties ...) ...)
+       ;; When no 'this' identifier was specified, use 'this-record'.
+       #'(define-record-type* type syntactic-ctor ctor pred
+           this-record
+           (field get properties ...) ...)))))
 
 (define* (alist->record alist make keys
                         #:optional (multiple-value-keys '()))
diff --git a/tests/records.scm b/tests/records.scm
index 45614093a0..16b7a9c35e 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -210,6 +210,24 @@
            (= 40 (foo-bar z))
            (= -2 (foo-baz z))))))
 
+(test-assert "define-record-type* & thunked & inherit & custom this"
+  (let ()
+    (define-record-type* <foo> foo make-foo
+      foo? this-foo
+      (thing foo-thing (thunked)))
+    (define-record-type* <bar> bar make-bar
+      bar? this-bar
+      (baz bar-baz (thunked)))
+
+    ;; Nest records and test the two self references.
+    (let* ((x (foo (thing (bar (baz (list this-bar this-foo))))))
+           (y (foo-thing x)))
+      (match (bar-baz y)
+        ((first second)
+         (and (eq? second x)
+              (bar? first)
+              (eq? first y)))))))
+
 (test-assert "define-record-type* & delayed"
   (begin
     (define-record-type* <foo> foo make-foo
-- 
cgit 1.4.1