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>

2 files changed, 69 insertions, 22 deletions

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 ...)
diff --git a/tests/records.scm b/tests/records.scm
index b1203dfeb7..4f0aeb3903 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -561,4 +561,33 @@ Description: 1st line,
             (make-fresh-user-module)))
     (lambda (key . args) key)))
 
+(test-equal "match-record, delayed field"
+  "foo bar bar foo"
+  (begin
+    (define-record-type* <with-delayed> with-delayed make-with-delayed
+      with-delayed?
+      (delayed  with-delayed-delayed
+                (delayed)))
+
+    (let ((rec (with-delayed
+                (delayed "foo bar bar foo"))))
+      (match-record rec <with-delayed> (delayed)
+        delayed))))
+
+(test-equal "match-record, thunked field"
+  '("foo" "foobar")
+  (begin
+    (define-record-type* <with-thunked> with-thunked make-with-thunked
+      with-thunked?
+      (normal   with-thunked-normal)
+      (thunked  with-thunked-thunked
+                (thunked)))
+
+    (let ((rec (with-thunked
+                (normal  "foo")
+                (thunked (string-append (with-thunked-normal this-record)
+                                        "bar")))))
+      (match-record rec <with-thunked> (normal thunked)
+        (list normal thunked)))))
+
 (test-end)