01/04: records: 'match-record' checks fields at macro-expansion time.

[guix-commits]

civodul pushed a commit to branch version-1.4.0
in repository guix.

commit 754a7660a1716998b557aedeb805ee9040afdcdf
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Sat Nov 19 17:23:04 2022 +0100

    records: 'match-record' checks fields at macro-expansion time.
    
    This allows 'match-record' to be more efficient (field offsets are
    computed at compilation time) and to report unknown fields at
    macro-expansion time.
    
    * guix/records.scm (map-fields): New macro.
    (define-record-type*)[rtd-identifier]: New procedure.
    Define TYPE as a macro and use a separate identifier for the RTD.
    (lookup-field, match-record-inner): New macros.
    (match-record): Rewrite in terms of 'match-error-inner'.
    * tests/records.scm ("match-record, simple")
    ("match-record, unknown field"): New tests.
    * gnu/services/cuirass.scm (cuirass-shepherd-service): Rename 'log-file'
    local variable to 'main-log-file'.
    * gnu/services/getmail.scm (serialize-getmail-configuration-file): Move
    after <getmail-configuration-file> definition.
---
 gnu/services/cuirass.scm |  4 +--
 gnu/services/getmail.scm | 22 ++++++------
 guix/records.scm         | 87 ++++++++++++++++++++++++++++++++++++++++++------
 tests/records.scm        | 33 ++++++++++++++++++
 4 files changed, 122 insertions(+), 24 deletions(-)

diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm
index 52de5ca7c0..d7c6ab9877 100644
--- a/gnu/services/cuirass.scm
+++ b/gnu/services/cuirass.scm
@@ -125,7 +125,7 @@
   (let ((cuirass          (cuirass-configuration-cuirass config))
         (cache-directory  (cuirass-configuration-cache-directory config))
         (web-log-file     (cuirass-configuration-web-log-file config))
-        (log-file         (cuirass-configuration-log-file config))
+        (main-log-file    (cuirass-configuration-log-file config))
         (user             (cuirass-configuration-user config))
         (group            (cuirass-configuration-group config))
         (interval         (cuirass-configuration-interval config))
@@ -169,7 +169,7 @@
 
                   #:user #$user
                   #:group #$group
-                  #:log-file #$log-file))
+                  #:log-file #$main-log-file))
         (stop #~(make-kill-destructor)))
       ,(shepherd-service
         (documentation "Run Cuirass web interface.")
diff --git a/gnu/services/getmail.scm b/gnu/services/getmail.scm
index fb82d054ca..19faea782f 100644
--- a/gnu/services/getmail.scm
+++ b/gnu/services/getmail.scm
@@ -215,17 +215,6 @@ lines.")
    (parameter-alist '())
    "Extra options to include."))
 
-(define (serialize-getmail-configuration-file field-name val)
-  (match-record val <getmail-configuration-file>
-    (retriever destination options)
-    #~(string-append
-       "[retriever]\n"
-       #$(serialize-getmail-retriever-configuration #f retriever)
-       "\n[destination]\n"
-       #$(serialize-getmail-destination-configuration #f destination)
-       "\n[options]\n"
-       #$(serialize-getmail-options-configuration #f options))))
-
 (define-configuration getmail-configuration-file
   (retriever
    (getmail-retriever-configuration (getmail-retriever-configuration))
@@ -237,6 +226,17 @@ lines.")
    (getmail-options-configuration (getmail-options-configuration))
    "Configure getmail."))
 
+(define (serialize-getmail-configuration-file field-name val)
+  (match-record val <getmail-configuration-file>
+    (retriever destination options)
+    #~(string-append
+       "[retriever]\n"
+       #$(serialize-getmail-retriever-configuration #f retriever)
+       "\n[destination]\n"
+       #$(serialize-getmail-destination-configuration #f destination)
+       "\n[options]\n"
+       #$(serialize-getmail-options-configuration #f options))))
+
 (define (serialize-symbol field-name val) "")
 (define (serialize-getmail-configuration field-name val) "")
 
diff --git a/guix/records.scm b/guix/records.scm
index ed94c83dac..13463647c8 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 
Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012-2022 Ludovic Courtès <ludo@gnu.org>
 ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
 ;;;
 ;;; This file is part of GNU Guix.
@@ -104,6 +104,10 @@ error-reporting purposes."
            (()
             #t)))))))
 
+(define-syntax map-fields
+  (lambda (x)
+    (syntax-violation 'map-fields "bad use of syntactic keyword" x x)))
+
 (define-syntax-parameter this-record
   (lambda (s)
     "Return the record being defined.  This macro may only be used in the
@@ -325,6 +329,15 @@ This expression returns a new object equal to 'x' except 
for its 'name'
 field and its 'loc' field---the latter is marked as \"innate\", so it is not
 inherited."
 
+    (define (rtd-identifier type)
+      ;; Return an identifier derived from TYPE to name its record type
+      ;; descriptor (RTD).
+      (let ((type-name (syntax->datum type)))
+        (datum->syntax
+         type
+         (string->symbol
+          (string-append "% " (symbol->string type-name) " rtd")))))
+
     (define (field-default-value s)
       (syntax-case s (default)
         ((field (default val) _ ...)
@@ -428,10 +441,31 @@ inherited."
                                             field)))
                                     field-spec)))
            #`(begin
-               (define-record-type type
+               (define-record-type #,(rtd-identifier #'type)
                  (ctor field ...)
                  pred
                  field-spec* ...)
+
+               ;; Rectify the vtable type name...
+               (set-struct-vtable-name! #,(rtd-identifier #'type) 'type)
+               (cond-expand
+                (guile-3
+                 ;; ... and the record type name.
+                 (struct-set! #,(rtd-identifier #'type) vtable-offset-user
+                              'type))
+                (else #f))
+
+               (define-syntax type
+                 (lambda (s)
+                   "This macro lets us query record type info at
+macro-expansion time."
+                   (syntax-case s (map-fields)
+                     ((_ map-fields macro)
+                      #'(macro (field ...)))
+                     (id
+                      (identifier? #'id)
+                      #'#,(rtd-identifier #'type)))))
+
                (define #,(current-abi-identifier #'type)
                  #,cookie)
 
@@ -535,19 +569,50 @@ pairs.  Stop upon an empty line (after consuming it) or 
EOF."
               (else
                (error "unmatched line" line))))))))
 
+
+;;;
+;;; Pattern matching.
+;;;
+
+(define-syntax lookup-field
+  (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"
+                         s #'field))
+      ((_ field offset (head tail ...))
+       (free-identifier=? #'field #'head)
+       #'offset)
+      ((_ field offset (_ tail ...))
+       #'(lookup-field field (+ 1 offset) (tail ...))))))
+
+(define-syntax match-record-inner
+  (lambda (s)
+    (syntax-case s ()
+      ((_ record type (field rest ...) body ...)
+       #`(let-syntax ((field-offset (syntax-rules ()
+                                     ((_ f)
+                                       (lookup-field field 0 f)))))
+           (let* ((offset (type map-fields field-offset))
+                  (field  (struct-ref record offset)))
+             (match-record-inner record type (rest ...) body ...))))
+      ((_ record type () body ...)
+       #'(begin body ...)))))
+
 (define-syntax match-record
   (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."
-    ((_ record type (field fields ...) body ...)
+    ;; TODO support thunked and delayed fields
+    ((_ record type (fields ...) body ...)
      (if (eq? (struct-vtable record) type)
-         ;; TODO compute indices and report wrong-field-name errors at
-         ;;      expansion time
-         ;; TODO support thunked and delayed fields
-         (let ((field ((record-accessor type 'field) record)))
-           (match-record record type (fields ...) body ...))
-         (throw 'wrong-type-arg record)))
-    ((_ record type () body ...)
-     (begin body ...))))
+         (match-record-inner record type (fields ...) body ...)
+         (throw 'wrong-type-arg record)))))
 
 ;;; records.scm ends here
diff --git a/tests/records.scm b/tests/records.scm
index 00c58b0736..8504c8d5a5 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -528,4 +528,37 @@ Description: 1st line,
                  '("a" "b" "c")
                  '("a")))
 
+(test-equal "match-record, simple"
+  '((1 2) (a b))
+  (let ()
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (first  foo-first (default 1))
+      (second foo-second))
+
+    (list (match-record (foo (second 2)) <foo>
+            (first second)
+            (list first second))
+          (match-record (foo (first 'a) (second 'b)) <foo>
+            (second first)
+            (list first second)))))
+
+(test-equal "match-record, unknown field"
+  'syntax-error
+  (catch 'syntax-error
+    (lambda ()
+      (eval '(begin
+               (use-modules (guix records))
+
+               (define-record-type* <foo> foo make-foo
+                 foo?
+                 (first  foo-first (default 1))
+                 (second foo-second))
+
+               (match-record (foo (second 2)) <foo>
+                 (one two)
+                 #f))
+            (make-fresh-user-module)))
+    (lambda (key . args) key)))
+
 (test-end)