records: Replace 'eval-when' with a proper 'define-syntax'.
* guix/records.scm (make-syntactic-constructor): Remove enclosing 'eval-when'. Turn into a 'syntax-rules' macro.master
Ludovic Courtès
parent
b45ce07a8a
commit
39fc041a7d
188
guix/records.scm
188
guix/records.scm
|
|
@ -42,106 +42,102 @@
|
||||||
(format #f fmt args ...)
|
(format #f fmt args ...)
|
||||||
form))))
|
form))))
|
||||||
|
|
||||||
(eval-when (expand load eval)
|
(define-syntax make-syntactic-constructor
|
||||||
;; This procedure is a syntactic helper used by 'define-record-type*', hence
|
(syntax-rules ()
|
||||||
;; 'eval-when'.
|
"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, and DELAYED is the list of identifiers of delayed fields."
|
||||||
|
((_ type name ctor (expected ...)
|
||||||
|
#:thunked thunked
|
||||||
|
#:delayed delayed
|
||||||
|
#: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))
|
||||||
|
|
||||||
(define* (make-syntactic-constructor type name ctor fields
|
;; Make sure there are no unknown field names.
|
||||||
#:key (thunked '()) (defaults '())
|
(let* ((fields (map (compose car syntax->datum) field+value))
|
||||||
(delayed '()))
|
(unexpected (lset-difference eq? fields '(expected ...))))
|
||||||
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects
|
(when (pair? unexpected)
|
||||||
all of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE
|
(record-error 'name s "extraneous field initializers ~a"
|
||||||
tuples, THUNKED is the list of identifiers of thunked fields, and DELAYED is
|
unexpected)))
|
||||||
the list of identifiers of delayed fields."
|
|
||||||
(with-syntax ((type type)
|
|
||||||
(name name)
|
|
||||||
(ctor ctor)
|
|
||||||
(expected fields)
|
|
||||||
(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.
|
#`(make-struct type 0
|
||||||
(let* ((fields (map (compose car syntax->datum) field+value))
|
#,@(map (lambda (field index)
|
||||||
(unexpected (lset-difference eq? fields 'expected)))
|
(or (field-inherited-value field)
|
||||||
(when (pair? unexpected)
|
#`(struct-ref #,orig-record
|
||||||
(record-error 'name s "extraneous field initializers ~a"
|
#,index)))
|
||||||
unexpected)))
|
'(expected ...)
|
||||||
|
(iota (length '(expected ...))))))
|
||||||
|
|
||||||
#`(make-struct type 0
|
(define (thunked-field? f)
|
||||||
#,@(map (lambda (field index)
|
(memq (syntax->datum f) 'thunked))
|
||||||
(or (field-inherited-value field)
|
|
||||||
#`(struct-ref #,orig-record
|
|
||||||
#,index)))
|
|
||||||
'expected
|
|
||||||
(iota (length 'expected)))))
|
|
||||||
|
|
||||||
(define (thunked-field? f)
|
(define (delayed-field? f)
|
||||||
(memq (syntax->datum f) '#,thunked))
|
(memq (syntax->datum f) 'delayed))
|
||||||
|
|
||||||
(define (delayed-field? f)
|
(define (wrap-field-value f value)
|
||||||
(memq (syntax->datum f) '#,delayed))
|
(cond ((thunked-field? f)
|
||||||
|
#`(lambda () #,value))
|
||||||
|
((delayed-field? f)
|
||||||
|
#`(delay #,value))
|
||||||
|
(else value)))
|
||||||
|
|
||||||
(define (wrap-field-value f value)
|
(define (field-bindings field+value)
|
||||||
(cond ((thunked-field? f)
|
;; Return field to value bindings, for use in 'let*' below.
|
||||||
#`(lambda () #,value))
|
(map (lambda (field+value)
|
||||||
((delayed-field? f)
|
(syntax-case field+value ()
|
||||||
#`(delay #,value))
|
((field value)
|
||||||
(else value)))
|
#`(field
|
||||||
|
#,(wrap-field-value #'field #'value)))))
|
||||||
|
field+value))
|
||||||
|
|
||||||
(define (field-bindings field+value)
|
(syntax-case s (inherit expected ...)
|
||||||
;; Return field to value bindings, for use in 'let*' below.
|
((_ (inherit orig-record) (field value) (... ...))
|
||||||
(map (lambda (field+value)
|
#`(let* #,(field-bindings #'((field value) (... ...)))
|
||||||
(syntax-case field+value ()
|
#,(record-inheritance #'orig-record
|
||||||
((field value)
|
#'((field value) (... ...)))))
|
||||||
#`(field
|
((_ (field value) (... ...))
|
||||||
#,(wrap-field-value #'field #'value)))))
|
(let ((fields (map syntax->datum #'(field (... ...))))
|
||||||
field+value))
|
(dflt (map (match-lambda
|
||||||
|
((f v)
|
||||||
|
(list (syntax->datum f) v)))
|
||||||
|
#'defaults)))
|
||||||
|
|
||||||
(syntax-case s (inherit #,@fields)
|
(define (field-value f)
|
||||||
((_ (inherit orig-record) (field value) (... ...))
|
(or (and=> (find (lambda (x)
|
||||||
#`(let* #,(field-bindings #'((field value) (... ...)))
|
(eq? f (car (syntax->datum x))))
|
||||||
#,(record-inheritance #'orig-record
|
#'((field value) (... ...)))
|
||||||
#'((field value) (... ...)))))
|
car)
|
||||||
((_ (field value) (... ...))
|
(let ((value
|
||||||
(let ((fields (map syntax->datum #'(field (... ...))))
|
(car (assoc-ref dflt (syntax->datum f)))))
|
||||||
(dflt (map (match-lambda
|
(wrap-field-value f value))))
|
||||||
((f v)
|
|
||||||
(list (syntax->datum f) v)))
|
|
||||||
#'defaults)))
|
|
||||||
|
|
||||||
(define (field-value f)
|
(let ((fields (append fields (map car dflt))))
|
||||||
(or (and=> (find (lambda (x)
|
(cond ((lset= eq? fields '(expected ...))
|
||||||
(eq? f (car (syntax->datum x))))
|
#`(let* #,(field-bindings
|
||||||
#'((field value) (... ...)))
|
#'((field value) (... ...)))
|
||||||
car)
|
(ctor #,@(map field-value '(expected ...)))))
|
||||||
(let ((value
|
((pair? (lset-difference eq? fields
|
||||||
(car (assoc-ref dflt (syntax->datum f)))))
|
'(expected ...)))
|
||||||
(wrap-field-value f value))))
|
(record-error 'name s
|
||||||
|
"extraneous field initializers ~a"
|
||||||
(let ((fields (append fields (map car dflt))))
|
(lset-difference eq? fields
|
||||||
(cond ((lset= eq? fields 'expected)
|
'(expected ...))))
|
||||||
#`(let* #,(field-bindings
|
(else
|
||||||
#'((field value) (... ...)))
|
(record-error 'name s
|
||||||
(ctor #,@(map field-value 'expected))))
|
"missing field initializers ~a"
|
||||||
((pair? (lset-difference eq? fields 'expected))
|
(lset-difference eq?
|
||||||
(record-error 'name s
|
'(expected ...)
|
||||||
"extraneous field initializers ~a"
|
fields)))))))))))))
|
||||||
(lset-difference eq? fields
|
|
||||||
'expected)))
|
|
||||||
(else
|
|
||||||
(record-error 'name s
|
|
||||||
"missing field initializers ~a"
|
|
||||||
(lset-difference eq? 'expected
|
|
||||||
fields)))))))))))))
|
|
||||||
|
|
||||||
(define-syntax define-record-type*
|
(define-syntax define-record-type*
|
||||||
(lambda (s)
|
(lambda (s)
|
||||||
|
|
@ -279,11 +275,11 @@ field."
|
||||||
field-spec* ...)
|
field-spec* ...)
|
||||||
(begin thunked-field-accessor ...
|
(begin thunked-field-accessor ...
|
||||||
delayed-field-accessor ...)
|
delayed-field-accessor ...)
|
||||||
#,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
|
(make-syntactic-constructor type syntactic-ctor ctor
|
||||||
#'(field ...)
|
(field ...)
|
||||||
#:thunked thunked
|
#:thunked #,thunked
|
||||||
#:delayed delayed
|
#:delayed #,delayed
|
||||||
#:defaults defaults))))))))
|
#:defaults #,defaults))))))))
|
||||||
|
|
||||||
(define* (alist->record alist make keys
|
(define* (alist->record alist make keys
|
||||||
#:optional (multiple-value-keys '()))
|
#:optional (multiple-value-keys '()))
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue