mirror of
https://git.in.rschanz.org/ryan77627/guix.git
synced 2024-11-07 15:36:20 -05:00
658 lines
27 KiB
Scheme
658 lines
27 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2012-2023 Ludovic Courtès <ludo@gnu.org>
|
||
;;; Copyright © 2018 Mark H Weaver <mhw@netris.org>
|
||
;;;
|
||
;;; This file is part of GNU Guix.
|
||
;;;
|
||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||
;;; under the terms of the GNU General Public License as published by
|
||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||
;;; your option) any later version.
|
||
;;;
|
||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
;;; GNU General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU General Public License
|
||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||
|
||
(define-module (guix records)
|
||
#:use-module (srfi srfi-1)
|
||
#:use-module (srfi srfi-9)
|
||
#:use-module (srfi srfi-11)
|
||
#:use-module (srfi srfi-26)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (ice-9 rdelim)
|
||
#:autoload (system base target) (target-most-positive-fixnum)
|
||
#:export (define-record-type*
|
||
this-record
|
||
|
||
alist->record
|
||
object->fields
|
||
recutils->alist
|
||
match-record
|
||
match-record-lambda))
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; Utilities for dealing with Scheme records.
|
||
;;;
|
||
;;; Code:
|
||
|
||
(define-syntax record-error
|
||
(syntax-rules ()
|
||
"Report a syntactic error in use of CONSTRUCTOR."
|
||
((_ constructor form fmt args ...)
|
||
(syntax-violation constructor
|
||
(format #f fmt args ...)
|
||
form))))
|
||
|
||
(eval-when (expand load eval)
|
||
;; The procedures below are needed both at run time and at expansion time.
|
||
|
||
(define (current-abi-identifier type)
|
||
"Return an identifier unhygienically derived from TYPE for use as its
|
||
\"current ABI\" variable."
|
||
(let ((type-name (syntax->datum type)))
|
||
(datum->syntax
|
||
type
|
||
(string->symbol
|
||
(string-append "% " (symbol->string type-name)
|
||
" abi-cookie")))))
|
||
|
||
(define (abi-check type cookie)
|
||
"Return syntax that checks that the current \"application binary
|
||
interface\" (ABI) for TYPE is equal to COOKIE."
|
||
(with-syntax ((current-abi (current-abi-identifier type)))
|
||
#`(unless (eq? current-abi #,cookie)
|
||
;; The source file where this exception is thrown must be
|
||
;; recompiled.
|
||
(throw 'record-abi-mismatch-error 'abi-check
|
||
"~a: record ABI mismatch; recompilation needed"
|
||
(list #,type) '()))))
|
||
|
||
(define* (report-invalid-field-specifier name bindings
|
||
#:optional parent-form)
|
||
"Report the first invalid binding among BINDINGS. PARENT-FORM is used for
|
||
error-reporting purposes."
|
||
(let loop ((bindings bindings))
|
||
(syntax-case bindings ()
|
||
(((field value) rest ...) ;good
|
||
(loop #'(rest ...)))
|
||
((weird _ ...) ;weird!
|
||
;; WEIRD may be an identifier, thus lacking source location info, and
|
||
;; BINDINGS is a list, also lacking source location info. Hopefully
|
||
;; PARENT-FORM provides source location info.
|
||
(apply syntax-violation name "invalid field specifier"
|
||
(if parent-form
|
||
(list parent-form #'weird)
|
||
(list #'weird)))))))
|
||
|
||
(define (report-duplicate-field-specifier name ctor)
|
||
"Report the first duplicate identifier among the bindings in CTOR."
|
||
(syntax-case ctor ()
|
||
((_ bindings ...)
|
||
(let loop ((bindings #'(bindings ...))
|
||
(seen '()))
|
||
(syntax-case bindings ()
|
||
(((field value) rest ...)
|
||
(not (memq (syntax->datum #'field) seen))
|
||
(loop #'(rest ...) (cons (syntax->datum #'field) seen)))
|
||
((duplicate rest ...)
|
||
(syntax-violation name "duplicate field initializer"
|
||
#'duplicate))
|
||
(()
|
||
#t)))))))
|
||
|
||
(define-syntax map-fields
|
||
(lambda (x)
|
||
(syntax-case x ()
|
||
((_ type within)
|
||
(syntax-violation (syntax->datum #'within)
|
||
"undefined record type"
|
||
#'type))
|
||
(_ (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
|
||
context of the definition of a thunked field."
|
||
(syntax-case s ()
|
||
(id
|
||
(identifier? #'id)
|
||
(syntax-violation 'this-record
|
||
"cannot be used outside of a record instantiation"
|
||
#'id)))))
|
||
|
||
(define-syntax make-syntactic-constructor
|
||
(syntax-rules ()
|
||
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and
|
||
expects all of EXPECTED fields to be initialized. DEFAULTS is the list of
|
||
FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
|
||
fields, DELAYED is the list of identifiers of delayed fields, and SANITIZERS
|
||
is the list of FIELD/SANITIZER tuples.
|
||
|
||
ABI-COOKIE is the cookie (an integer) against which to check the run-time ABI
|
||
of TYPE matches the expansion-time ABI."
|
||
((_ type name ctor (expected ...)
|
||
#:abi-cookie abi-cookie
|
||
#:thunked thunked
|
||
#:this-identifier this-identifier
|
||
#:delayed delayed
|
||
#:innate innate
|
||
#:sanitizers sanitizers
|
||
#:defaults defaults)
|
||
(define-syntax name
|
||
(lambda (s)
|
||
(define (record-inheritance orig-record field+value)
|
||
;; Produce code that returns a record identical to ORIG-RECORD,
|
||
;; except that values for the FIELD+VALUE alist prevail.
|
||
(define (field-inherited-value f)
|
||
(and=> (find (lambda (x)
|
||
(eq? f (car (syntax->datum x))))
|
||
field+value)
|
||
car))
|
||
|
||
;; Make sure there are no unknown field names.
|
||
(let* ((fields (map (compose car syntax->datum) field+value))
|
||
(unexpected (lset-difference eq? fields '(expected ...))))
|
||
(when (pair? unexpected)
|
||
(record-error 'name s "extraneous field initializers ~a"
|
||
unexpected)))
|
||
|
||
#`(make-struct/no-tail type
|
||
#,@(map (lambda (field index)
|
||
(or (field-inherited-value field)
|
||
(if (innate-field? field)
|
||
(wrap-field-value
|
||
field (field-default-value field))
|
||
#`(struct-ref #,orig-record
|
||
#,index))))
|
||
'(expected ...)
|
||
(iota (length '(expected ...))))))
|
||
|
||
(define (thunked-field? f)
|
||
(memq (syntax->datum f) 'thunked))
|
||
|
||
(define (delayed-field? f)
|
||
(memq (syntax->datum f) 'delayed))
|
||
|
||
(define (innate-field? f)
|
||
(memq (syntax->datum f) 'innate))
|
||
|
||
(define field-sanitizer
|
||
(let ((lst (map (match-lambda
|
||
((f p)
|
||
(list (syntax->datum f) p)))
|
||
#'sanitizers)))
|
||
(lambda (f)
|
||
(or (and=> (assoc-ref lst (syntax->datum f)) car)
|
||
#'(lambda (x) x)))))
|
||
|
||
(define (wrap-field-value f value)
|
||
(let* ((sanitizer (field-sanitizer f))
|
||
(value #`(#,sanitizer #,value)))
|
||
(cond ((thunked-field? f)
|
||
#`(lambda (x)
|
||
(syntax-parameterize ((#,this-identifier
|
||
(lambda (s)
|
||
(syntax-case s ()
|
||
(id
|
||
(identifier? #'id)
|
||
#'x)))))
|
||
#,value)))
|
||
((delayed-field? f)
|
||
#`(delay #,value))
|
||
(else value))))
|
||
|
||
(define default-values
|
||
;; List of symbol/value tuples.
|
||
(map (match-lambda
|
||
((f v)
|
||
(list (syntax->datum f) v)))
|
||
#'defaults))
|
||
|
||
(define (field-default-value f)
|
||
(car (assoc-ref default-values (syntax->datum f))))
|
||
|
||
(define (field-bindings field+value)
|
||
;; Return field to value bindings, for use in 'let*' below.
|
||
(map (lambda (field+value)
|
||
(syntax-case field+value ()
|
||
((field value)
|
||
#`(field
|
||
#,(wrap-field-value #'field #'value)))))
|
||
field+value))
|
||
|
||
(syntax-case s (inherit expected ...)
|
||
((_ (inherit orig-record) (field value) (... ...))
|
||
#`(let* #,(field-bindings #'((field value) (... ...)))
|
||
#,(abi-check #'type abi-cookie)
|
||
#,(record-inheritance #'orig-record
|
||
#'((field value) (... ...)))))
|
||
((_ (field value) (... ...))
|
||
(let ((fields (map syntax->datum #'(field (... ...)))))
|
||
(define (field-value f)
|
||
(or (find (lambda (x)
|
||
(eq? f (syntax->datum x)))
|
||
#'(field (... ...)))
|
||
(wrap-field-value f (field-default-value f))))
|
||
|
||
;; Pass S to make sure source location info is preserved.
|
||
(report-duplicate-field-specifier 'name s)
|
||
|
||
(let ((fields (append fields (map car default-values))))
|
||
(cond ((lset= eq? fields '(expected ...))
|
||
#`(let* #,(field-bindings
|
||
#'((field value) (... ...)))
|
||
#,(abi-check #'type abi-cookie)
|
||
(ctor #,@(map field-value '(expected ...)))))
|
||
((pair? (lset-difference eq? fields
|
||
'(expected ...)))
|
||
(record-error 'name s
|
||
"extraneous field initializers ~a"
|
||
(lset-difference eq? fields
|
||
'(expected ...))))
|
||
(else
|
||
(record-error 'name s
|
||
"missing field initializers ~a"
|
||
(lset-difference eq?
|
||
'(expected ...)
|
||
fields)))))))
|
||
((_ bindings (... ...))
|
||
;; One of BINDINGS doesn't match the (field value) pattern.
|
||
;; Report precisely which one is faulty, instead of letting the
|
||
;; "source expression failed to match any pattern" error.
|
||
(report-invalid-field-specifier 'name
|
||
#'(bindings (... ...))
|
||
s))))))))
|
||
|
||
(define-syntax-rule (define-field-property-predicate predicate property)
|
||
"Define PREDICATE as a procedure that takes a syntax object and, when passed
|
||
a field specification, returns the field name if it has the given PROPERTY."
|
||
(define (predicate s)
|
||
(syntax-case s (property)
|
||
((field (property values (... ...)) _ (... ...))
|
||
#'field)
|
||
((field _ properties (... ...))
|
||
(predicate #'(field properties (... ...))))
|
||
(_ #f))))
|
||
|
||
(define-syntax define-record-type*
|
||
(lambda (s)
|
||
"Define the given record type such that an additional \"syntactic
|
||
constructor\" is defined, which allows instances to be constructed with named
|
||
field initializers, à la SRFI-35, as well as default values. An example use
|
||
may look like this:
|
||
|
||
(define-record-type* <thing> thing make-thing
|
||
thing?
|
||
this-thing
|
||
(name thing-name (default \"chbouib\"))
|
||
(port thing-port
|
||
(default (current-output-port)) (thunked))
|
||
(loc thing-location (innate) (default (current-source-location))))
|
||
|
||
This example defines a macro 'thing' that can be used to instantiate records
|
||
of this type:
|
||
|
||
(thing
|
||
(name \"foo\")
|
||
(port (current-error-port)))
|
||
|
||
The value of 'name' or 'port' could as well be omitted, in which case the
|
||
default value specified in the 'define-record-type*' form is used:
|
||
|
||
(thing)
|
||
|
||
The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
|
||
actually compute the field's value in the current dynamic extent, which is
|
||
useful when referring to fluids in a field's value. Furthermore, that thunk
|
||
can access the record it belongs to via the 'this-thing' identifier.
|
||
|
||
A field can also be marked as \"delayed\" instead of \"thunked\", in which
|
||
case its value is effectively wrapped in a (delay …) form.
|
||
|
||
A field can also have an associated \"sanitizer\", which is a procedure that
|
||
takes a user-supplied field value and returns a \"sanitized\" value for the
|
||
field:
|
||
|
||
(define-record-type* <thing> thing make-thing
|
||
thing?
|
||
this-thing
|
||
(name thing-name
|
||
(sanitize (lambda (value)
|
||
(cond ((string? value) value)
|
||
((symbol? value) (symbol->string value))
|
||
(else (throw 'bad! value)))))))
|
||
|
||
It is possible to copy an object 'x' created with 'thing' like this:
|
||
|
||
(thing (inherit x) (name \"bar\"))
|
||
|
||
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) _ ...)
|
||
(list #'field #'val))
|
||
((field _ properties ...)
|
||
(field-default-value #'(field properties ...)))
|
||
(_ #f)))
|
||
|
||
(define (field-sanitizer s)
|
||
(syntax-case s (sanitize)
|
||
((field (sanitize proc) _ ...)
|
||
(list #'field #'proc))
|
||
((field _ properties ...)
|
||
(field-sanitizer #'(field properties ...)))
|
||
(_ #f)))
|
||
|
||
(define-field-property-predicate delayed-field? delayed)
|
||
(define-field-property-predicate thunked-field? thunked)
|
||
(define-field-property-predicate innate-field? innate)
|
||
|
||
(define (wrapped-field? s)
|
||
(or (thunked-field? s) (delayed-field? s)))
|
||
|
||
(define (wrapped-field-accessor-name field)
|
||
;; Return the name (an unhygienic syntax object) of the "real"
|
||
;; getter for field, which is assumed to be a wrapped field.
|
||
(syntax-case field ()
|
||
((field get properties ...)
|
||
(let* ((getter (syntax->datum #'get))
|
||
(real-getter (symbol-append '% getter '-real)))
|
||
(datum->syntax #'get real-getter)))))
|
||
|
||
(define (field-spec->srfi-9 field)
|
||
;; Convert a field spec of our style to a SRFI-9 field spec of the
|
||
;; form (field get).
|
||
(syntax-case field ()
|
||
((name get properties ...)
|
||
#`(name
|
||
#,(if (wrapped-field? field)
|
||
(wrapped-field-accessor-name field)
|
||
#'get)))))
|
||
|
||
(define (thunked-field-accessor-definition field)
|
||
;; Return the real accessor for FIELD, which is assumed to be a
|
||
;; thunked field.
|
||
(syntax-case field ()
|
||
((name get _ ...)
|
||
(with-syntax ((real-get (wrapped-field-accessor-name field)))
|
||
#'(define-inlinable (get x)
|
||
;; The real value of that field is a thunk, so call it.
|
||
((real-get x) x))))))
|
||
|
||
(define (delayed-field-accessor-definition field)
|
||
;; Return the real accessor for FIELD, which is assumed to be a
|
||
;; delayed field.
|
||
(syntax-case field ()
|
||
((name get _ ...)
|
||
(with-syntax ((real-get (wrapped-field-accessor-name field)))
|
||
#'(define-inlinable (get x)
|
||
;; The real value of that field is a promise, so force it.
|
||
(force (real-get x)))))))
|
||
|
||
(define (compute-abi-cookie field-specs)
|
||
;; Compute an "ABI cookie" for the given FIELD-SPECS. We use
|
||
;; 'string-hash' because that's a better hash function that 'hash' on a
|
||
;; list of symbols.
|
||
(syntax-case field-specs ()
|
||
(((field get properties ...) ...)
|
||
(string-hash (object->string
|
||
(syntax->datum #'((field properties ...) ...)))
|
||
(cond-expand
|
||
(guile-3 (target-most-positive-fixnum))
|
||
(else most-positive-fixnum))))))
|
||
|
||
(syntax-case s ()
|
||
((_ type syntactic-ctor ctor pred
|
||
this-identifier
|
||
(field get properties ...) ...)
|
||
(identifier? #'this-identifier)
|
||
(let* ((field-spec #'((field get properties ...) ...))
|
||
(thunked (filter-map thunked-field? field-spec))
|
||
(delayed (filter-map delayed-field? field-spec))
|
||
(innate (filter-map innate-field? field-spec))
|
||
(defaults (filter-map field-default-value
|
||
#'((field properties ...) ...)))
|
||
(sanitizers (filter-map field-sanitizer
|
||
#'((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)
|
||
(thunked-field-accessor-definition
|
||
field)))
|
||
field-spec))
|
||
((delayed-field-accessor ...)
|
||
(filter-map (lambda (field)
|
||
(and (delayed-field? field)
|
||
(delayed-field-accessor-definition
|
||
field)))
|
||
field-spec)))
|
||
#`(begin
|
||
(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 field-type) ...)))
|
||
(id
|
||
(identifier? #'id)
|
||
#'#,(rtd-identifier #'type)))))
|
||
|
||
(define #,(current-abi-identifier #'type)
|
||
#,cookie)
|
||
|
||
#,@(if (free-identifier=? #'this-identifier #'this-record)
|
||
#'()
|
||
#'((define-syntax-parameter this-identifier
|
||
(lambda (s)
|
||
"Return the record being defined. This macro may
|
||
only be used in the context of the definition of a thunked field."
|
||
(syntax-case s ()
|
||
(id
|
||
(identifier? #'id)
|
||
(syntax-violation 'this-identifier
|
||
"cannot be used outside \
|
||
of a record instantiation"
|
||
#'id)))))))
|
||
thunked-field-accessor ...
|
||
delayed-field-accessor ...
|
||
(make-syntactic-constructor type syntactic-ctor ctor
|
||
(field ...)
|
||
#:abi-cookie #,cookie
|
||
#:thunked #,thunked
|
||
#:this-identifier #'this-identifier
|
||
#:delayed #,delayed
|
||
#:innate #,innate
|
||
#:sanitizers #,sanitizers
|
||
#:defaults #,defaults)))))
|
||
((_ type syntactic-ctor ctor pred
|
||
(field get properties ...) ...)
|
||
;; When no 'this' identifier was specified, use 'this-record'.
|
||
#'(define-record-type* type syntactic-ctor ctor pred
|
||
this-record
|
||
(field get properties ...) ...)))))
|
||
|
||
(define* (alist->record alist make keys
|
||
#:optional (multiple-value-keys '()))
|
||
"Apply MAKE to the values associated with KEYS in ALIST. Items in KEYS that
|
||
are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple
|
||
times in ALIST, and thus their value is a list."
|
||
(let ((args (map (lambda (key)
|
||
(if (member key multiple-value-keys)
|
||
(filter-map (match-lambda
|
||
((k . v)
|
||
(and (equal? k key) v)))
|
||
alist)
|
||
(assoc-ref alist key)))
|
||
keys)))
|
||
(apply make args)))
|
||
|
||
(define (object->fields object fields port)
|
||
"Write OBJECT (typically a record) as a series of recutils-style fields to
|
||
PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs."
|
||
(let loop ((fields fields))
|
||
(match fields
|
||
(()
|
||
object)
|
||
(((field . get) rest ...)
|
||
(format port "~a: ~a~%" field (get object))
|
||
(loop rest)))))
|
||
|
||
(define %recutils-field-charset
|
||
;; Valid characters starting a recutils field.
|
||
;; info "(recutils) Fields"
|
||
(char-set-union char-set:upper-case
|
||
char-set:lower-case
|
||
(char-set #\%)))
|
||
|
||
(define (recutils->alist port)
|
||
"Read a recutils-style record from PORT and return it as a list of key/value
|
||
pairs. Stop upon an empty line (after consuming it) or EOF."
|
||
(let loop ((line (read-line port))
|
||
(result '()))
|
||
(cond ((eof-object? line)
|
||
(reverse result))
|
||
((string-null? line)
|
||
(if (null? result)
|
||
(loop (read-line port) result) ; leading space: ignore it
|
||
(reverse result))) ; end-of-record marker
|
||
(else
|
||
;; Now check the first character of LINE, since that's what the
|
||
;; recutils manual says is enough.
|
||
(let ((first (string-ref line 0)))
|
||
(cond
|
||
((char-set-contains? %recutils-field-charset first)
|
||
(let* ((colon (string-index line #\:))
|
||
(field (string-take line colon))
|
||
(value (string-trim (string-drop line (+ 1 colon)))))
|
||
(loop (read-line port)
|
||
(alist-cons field value result))))
|
||
((eqv? first #\#) ;info "(recutils) Comments"
|
||
(loop (read-line port) result))
|
||
((eqv? first #\+) ;info "(recutils) Fields"
|
||
(let ((new-line (if (string-prefix? "+ " line)
|
||
(string-drop line 2)
|
||
(string-drop line 1))))
|
||
(match result
|
||
(((field . value) rest ...)
|
||
(loop (read-line port)
|
||
`((,field . ,(string-append value "\n" new-line))
|
||
,@rest))))))
|
||
(else
|
||
(error "unmatched line" line))))))))
|
||
|
||
|
||
;;;
|
||
;;; Pattern matching.
|
||
;;;
|
||
|
||
(define-syntax lookup-field+wrapper
|
||
(lambda (s)
|
||
"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"
|
||
;; Attach the local source data to the field.
|
||
(datum->syntax #f (syntax->datum #'field) #:source s)))
|
||
((_ record field offset ((head normal) tail ...))
|
||
(free-identifier=? #'field #'head)
|
||
#'(values offset identity))
|
||
((_ record field offset ((head delayed) tail ...))
|
||
(free-identifier=? #'field #'head)
|
||
#'(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+wrapper
|
||
(syntax-rules ()
|
||
((_ f)
|
||
(lookup-field+wrapper record field 0 f)))))
|
||
(let*-values (((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.
|
||
#'(match-record-inner record type ((field field) 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."
|
||
((_ record type (fields ...) body ...)
|
||
(if (eq? (struct-vtable record) type)
|
||
(match-record-inner record type (fields ...) body ...)
|
||
(throw 'wrong-type-arg record)))))
|
||
|
||
(define-syntax match-record-lambda
|
||
(syntax-rules ()
|
||
"Return a procedure accepting a single record of the given TYPE for which each
|
||
FIELD will be bound to its FIELD name within the returned procedure. A syntax error
|
||
is raised if an unknown field is queried."
|
||
((_ type (field ...) body ...)
|
||
(lambda (record)
|
||
(if (eq? (struct-vtable record) type)
|
||
(match-record-inner record type (field ...) body ...)
|
||
(throw 'wrong-type-arg record))))))
|
||
|
||
;;; records.scm ends here
|