mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-12-24 21:38:07 -05:00
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.
This commit is contained in:
parent
594f5ef351
commit
7c1161dba4
4 changed files with 122 additions and 24 deletions
|
@ -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 "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)
|
||||
|
|
Loading…
Reference in a new issue