diff options
Diffstat (limited to 'guix/utils.scm')
| -rw-r--r-- | guix/utils.scm | 52 |
1 files changed, 38 insertions, 14 deletions
diff --git a/guix/utils.scm b/guix/utils.scm index 686175947e..cec6df935b 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -477,17 +477,41 @@ starting from the right of 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." - (define (make-syntactic-constructor name ctor fields defaults) - "Make the syntactic constructor NAME that calls CTOR, and expects all -of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE -tuples." - (with-syntax ((name name) + (define (make-syntactic-constructor type name ctor fields defaults) + "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." + (with-syntax ((type type) + (name name) (ctor ctor) (expected fields) (defaults defaults)) - #'(define-syntax name + #`(define-syntax name (lambda (s) - (syntax-case s expected + (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-struct type 0 + #,@(map (lambda (field index) + (or (field-inherited-value field) + #`(struct-ref #,orig-record + #,index))) + 'expected + (iota (length 'expected))))) + + + (syntax-case s (inherit #,@fields) + ((_ (inherit orig-record) (field value) (... ...)) + #`(letrec* ((field value) (... ...)) + #,(record-inheritance #'orig-record + #'((field value) (... ...))))) ((_ (field value) (... ...)) (let ((fields (map syntax->datum #'(field (... ...)))) (dflt (map (match-lambda @@ -495,12 +519,12 @@ tuples." (list (syntax->datum f) v))) #'defaults))) - (define (field-value f) - (or (and=> (find (lambda (x) - (eq? f (car (syntax->datum x)))) - #'((field value) (... ...))) - car) - (car (assoc-ref dflt (syntax->datum f))))) + (define (field-value f) + (or (and=> (find (lambda (x) + (eq? f (car (syntax->datum x)))) + #'((field value) (... ...))) + car) + (car (assoc-ref dflt (syntax->datum f))))) (let-syntax ((error* (syntax-rules () @@ -537,7 +561,7 @@ tuples." (ctor field ...) pred (field get) ...) - #,(make-syntactic-constructor #'syntactic-ctor #'ctor + #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor #'(field ...) (filter-map field-default-value #'((field options ...) |