Skip to content
Snippets Groups Projects
Commit 954cea3a authored by Ludovic Courtès's avatar Ludovic Courtès
Browse files

records: Make 'make-syntactic-constructor' available at load/eval/expand. 

* guix/records.scm (make-syntactic-constructor): Wrap in 'eval-when'.
parent 88aab8e3
No related branches found
No related tags found
No related merge requests found
Hide whitespace changes
Inline Side-by-side
Showing
with 97 additions and 93 deletions
guix/records.scm
+ 97
− 93
View file @ 954cea3a
...@@ -42,102 +42,106 @@ (define-syntax record-error ...@@ -42,102 +42,106 @@ (define-syntax record-error
(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)
......
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment