@@ -125,7 +125,7 @@ (define (cuirass-shepherd-service config)
(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 @@ (define (cuirass-shepherd-service config)
#:user #$user
#:group #$group
- #:log-file #$log-file))
+ #:log-file #$main-log-file))
(stop #~(make-kill-destructor)))
,(shepherd-service
(documentation "Run Cuirass web interface.")
@@ -215,17 +215,6 @@ (define-configuration getmail-options-configuration
(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 @@ (define-configuration getmail-configuration-file
(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) "")
@@ -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 @@ (define (report-duplicate-field-specifier name ctor)
(()
#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 @@ (define-record-type* <thing> thing make-thing
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 @@ (define (compute-abi-cookie field-specs)
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 @@ (define (recutils->alist port)
(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
@@ -528,4 +528,37 @@ (define (make-me-a-record) (foo)))
'("a" "b" "c")
'("a")))
+(test-equal "record-match, 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 "record-match, 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)
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 ("record-match, simple") ("record-match, 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(-)