diff options
| -rw-r--r-- | guix/records.scm | 206 |
1 files changed, 101 insertions, 105 deletions
diff --git a/guix/records.scm b/guix/records.scm index db59a99052..2378969843 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -42,106 +42,102 @@ (format #f fmt args ...) form)))) -(eval-when (expand load eval) - ;; This procedure is a syntactic helper used by 'define-record-type*', hence - ;; 'eval-when'. - - (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 -tuples, THUNKED is the list of identifiers of thunked fields, and DELAYED is -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. - (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 type 0 - #,@(map (lambda (field index) - (or (field-inherited-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 (wrap-field-value f value) - (cond ((thunked-field? f) - #`(lambda () #,value)) - ((delayed-field? f) - #`(delay #,value)) - (else value))) - - (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 #,@fields) - ((_ (inherit orig-record) (field value) (... ...)) - #`(let* #,(field-bindings #'((field value) (... ...))) - #,(record-inheritance #'orig-record - #'((field value) (... ...))))) - ((_ (field value) (... ...)) - (let ((fields (map syntax->datum #'(field (... ...)))) - (dflt (map (match-lambda - ((f v) - (list (syntax->datum f) v))) - #'defaults))) - - (define (field-value f) - (or (and=> (find (lambda (x) - (eq? f (car (syntax->datum x)))) - #'((field value) (... ...))) - car) - (let ((value - (car (assoc-ref dflt (syntax->datum f))))) - (wrap-field-value f value)))) - - (let ((fields (append fields (map car dflt)))) - (cond ((lset= eq? fields 'expected) - #`(let* #,(field-bindings - #'((field value) (... ...))) - (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))))))))))))) +(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, 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)) + + ;; 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 type 0 + #,@(map (lambda (field index) + (or (field-inherited-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 (wrap-field-value f value) + (cond ((thunked-field? f) + #`(lambda () #,value)) + ((delayed-field? f) + #`(delay #,value)) + (else value))) + + (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) (... ...))) + #,(record-inheritance #'orig-record + #'((field value) (... ...))))) + ((_ (field value) (... ...)) + (let ((fields (map syntax->datum #'(field (... ...)))) + (dflt (map (match-lambda + ((f v) + (list (syntax->datum f) v))) + #'defaults))) + + (define (field-value f) + (or (and=> (find (lambda (x) + (eq? f (car (syntax->datum x)))) + #'((field value) (... ...))) + car) + (let ((value + (car (assoc-ref dflt (syntax->datum f))))) + (wrap-field-value f value)))) + + (let ((fields (append fields (map car dflt)))) + (cond ((lset= eq? fields '(expected ...)) + #`(let* #,(field-bindings + #'((field value) (... ...))) + (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))))))))))))) (define-syntax define-record-type* (lambda (s) @@ -279,11 +275,11 @@ field." field-spec* ...) (begin thunked-field-accessor ... delayed-field-accessor ...) - #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor - #'(field ...) - #:thunked thunked - #:delayed delayed - #:defaults defaults)))))))) + (make-syntactic-constructor type syntactic-ctor ctor + (field ...) + #:thunked #,thunked + #:delayed #,delayed + #:defaults #,defaults)))))))) (define* (alist->record alist make keys #:optional (multiple-value-keys '())) |