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