From b88e38d4b51b9aa0e857baeb614c000e491ad309 Mon Sep 17 00:00:00 2001
From: "(unmatched-parenthesis d" <paren@disroot.org>
Date: Fri, 28 Apr 2023 20:19:03 +0100
Subject: records: match-record: Support thunked and delayed fields.

* guix/records.scm (match-record): Unwrap matched thunked and delayed fields.
* tests/records.scm ("match-record, thunked field",
"match-record, delayed field"): New tests.

Signed-off-by: Josselin Poiret <dev@jpoiret.xyz>
---
 guix/records.scm | 62 ++++++++++++++++++++++++++++++++++++--------------------
 1 file changed, 40 insertions(+), 22 deletions(-)

(limited to 'guix/records.scm')

diff --git a/guix/records.scm b/guix/records.scm
index d8966998c1..cfa46f0d80 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -21,6 +21,7 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-9)
   #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-71)
   #:use-module (ice-9 match)
   #:use-module (ice-9 rdelim)
   #:autoload (system base target) (target-most-positive-fixnum)
@@ -428,10 +429,19 @@ inherited."
               (defaults   (filter-map field-default-value
                                       #'((field properties ...) ...)))
               (sanitizers (filter-map field-sanitizer
-                                        #'((field properties ...) ...)))
+                                      #'((field properties ...) ...)))
               (cookie     (compute-abi-cookie field-spec)))
          (with-syntax (((field-spec* ...)
                         (map field-spec->srfi-9 field-spec))
+                       ((field-type ...)
+                        (map (match-lambda
+                               ((? thunked-field?)
+                                (datum->syntax s 'thunked))
+                               ((? delayed-field?)
+                                (datum->syntax s 'delayed))
+                               (else
+                                (datum->syntax s 'normal)))
+                             field-spec))
                        ((thunked-field-accessor ...)
                         (filter-map (lambda (field)
                                       (and (thunked-field? field)
@@ -465,7 +475,7 @@ inherited."
 macro-expansion time."
                    (syntax-case s (map-fields)
                      ((_ (map-fields _ _) macro)
-                      #'(macro (field ...)))
+                      #'(macro ((field field-type) ...)))
                      (id
                       (identifier? #'id)
                       #'#,(rtd-identifier #'type)))))
@@ -578,30 +588,41 @@ pairs.  Stop upon an empty line (after consuming it) or EOF."
 ;;; Pattern matching.
 ;;;
 
-(define-syntax lookup-field
+(define-syntax lookup-field+wrapper
   (lambda (s)
-    "Look up FIELD in the given list and return an expression that represents
-its offset in the record.  Raise a syntax violation when the field is not
-found."
-    (syntax-case s ()
-      ((_ field offset ())
-       (syntax-violation 'lookup-field "unknown record type field"
+    "Look up FIELD in the given list and return both an expression that represents
+its offset in the record and a procedure that wraps it to return its \"true\" value
+(for instance, FORCE is returned in the case of a delayed field).  RECORD is passed
+to thunked values.  Raise a syntax violation when the field is not found."
+    (syntax-case s (normal delayed thunked)
+      ((_ record field offset ())
+       (syntax-violation 'match-record
+                         "unknown record type field"
                          s #'field))
-      ((_ field offset (head tail ...))
+      ((_ record field offset ((head normal) tail ...))
+       (free-identifier=? #'field #'head)
+       #'(values offset identity))
+      ((_ record field offset ((head delayed) tail ...))
        (free-identifier=? #'field #'head)
-       #'offset)
-      ((_ field offset (_ tail ...))
-       #'(lookup-field field (+ 1 offset) (tail ...))))))
+       #'(values offset force))
+      ((_ record field offset ((head thunked) tail ...))
+       (free-identifier=? #'field #'head)
+       #'(values offset (cut <> record)))
+      ((_ record field offset (_ tail ...))
+       #'(lookup-field+wrapper record field
+                               (+ 1 offset) (tail ...))))))
 
 (define-syntax match-record-inner
   (lambda (s)
     (syntax-case s ()
       ((_ record type ((field variable) rest ...) body ...)
-       #'(let-syntax ((field-offset (syntax-rules ()
-			              ((_ f)
-                                       (lookup-field field 0 f)))))
-           (let* ((offset (type (map-fields type match-record) field-offset))
-                  (variable (struct-ref record offset)))
+       #'(let-syntax ((field-offset+wrapper
+                       (syntax-rules ()
+			 ((_ f)
+                          (lookup-field+wrapper record field 0 f)))))
+           (let* ((offset wrap (type (map-fields type match-record)
+                                     field-offset+wrapper))
+                  (variable (wrap (struct-ref record offset))))
              (match-record-inner record type (rest ...) body ...))))
       ((_ record type (field rest ...) body ...)
        ;; Redirect to the canonical form above.
@@ -613,10 +634,7 @@ found."
   (syntax-rules ()
     "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name.
 The order in which fields appear does not matter.  A syntax error is raised if
-an unknown field is queried.
-
-The current implementation does not support thunked and delayed fields."
-    ;; TODO support thunked and delayed fields
+an unknown field is queried."
     ((_ record type (fields ...) body ...)
      (if (eq? (struct-vtable record) type)
          (match-record-inner record type (fields ...) body ...)
-- 
cgit v1.2.3