guix-bioinformatics
/
guix
mirror of http://git.savannah.gnu.org/git/guix.git
3
0
Fork 0
Code Issues Projects Releases Wiki Activity
Browse Source

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

* guix/records.scm (make-syntactic-constructor): Wrap in 'eval-when'.
version-0.8.3
Ludovic Courtès 7 years ago
parent
88aab8e349
commit
954cea3ae6
1 changed files with 97 additions and 93 deletions
Whitespace
Show all changes Ignore whitespace when comparing lines Ignore changes in amount of whitespace Ignore changes in whitespace at EOL
Split View
Diff Options
Show Stats Download Patch File Download Diff File
  1. 190
      guix/records.scm

190
guix/records.scm
View File

@ -42,102 +42,106 @@
(format #f fmt args ...)
form))))
(define* (make-syntactic-constructor type name ctor fields
#:key (thunked '()) (defaults '())
(delayed '()))
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects
(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))))))))))))
(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 define-record-type*
(lambda (s)

Write Preview
Loading…
Cancel
Save