nixo
/
guix-devel
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

define-record-type*: Add the `inherit' syntactic constructor keyword. 

* guix/utils.scm (define-record-type*)[make-syntactic-constructor]: New
  `type' parameter.  Add the `inherit' keyword and corresponding support
  code.

* tests/utils.scm ("define-record-type* & inherit", "define-record-type*
  & inherit & letrec* behavior"): New tests.
master
Ludovic Courtès 2012-08-30 00:18:50 +02:00
parent c79dae6076
commit dcd60f4398
2 changed files with 68 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

52
guix/utils.scm
View File

@ -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 ...)

30
tests/utils.scm
View File

@ -132,6 +132,36 @@
(match (bar (z 21) (x (/ z 3)))
(($ <bar> 7 42 21))))))
(test-assert "define-record-type* & inherit"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar)
(baz foo-baz (default (+ 40 2))))
(let* ((a (foo (bar 1)))
(b (foo (inherit a) (baz 2)))
(c (foo (inherit b) (bar -2)))
(d (foo (inherit c)))
(e (foo (inherit (foo (bar 42))) (baz 77))))
(and (match a (($ <foo> 1 42) #t))
(match b (($ <foo> 1 2) #t))
(match c (($ <foo> -2 2) #t))
(equal? c d)
(match e (($ <foo> 42 77) #t))))))
(test-assert "define-record-type* & inherit & letrec* behavior"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar)
(baz foo-baz (default (+ 40 2))))
(let* ((a (foo (bar 77)))
(b (foo (inherit a) (bar 1) (baz (+ bar 1))))
(c (foo (inherit b) (baz 2) (bar (- baz 1)))))
(and (match a (($ <foo> 77 42) #t))
(match b (($ <foo> 1 2) #t))
(equal? b c)))))
(test-end)