ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 21:38:07 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

records: Add support for 'innate' fields.

Browse source 
* guix/records.scm (make-syntactic-constructor): Add #:innate parameter.
  [record-inheritance]: Honor it.
  [innate-field?]: New procedure.
  (define-record-type*)[innate-field?]: New procedure.
  Pass #:innate to 'make-syntactic-constructor'.
* tests/records.scm ("define-record-type* & inherit & innate",
  "define-record-type* & thunked & innate"): New tests.
This commit is contained in:
Ludovic Courtès 2015-06-11 22:57:33 +02:00
parent 792798f486
commit 8a16d064fa
2 changed files with 46 additions and 4 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

18
guix/records.scm
View file

@ -51,6 +51,7 @@ (define-syntax make-syntactic-constructor
((_ type name ctor (expected ...)
#:thunked thunked
#:delayed delayed
#:innate innate
#:defaults defaults)
(define-syntax name
(lambda (s)
@ -73,8 +74,11 @@ (define (field-inherited-value f)
#`(make-struct type 0
#,@(map (lambda (field index)
(or (field-inherited-value field)
(if (innate-field? field)
(wrap-field-value
field (field-default-value field))
#`(struct-ref #,orig-record
#,index)))
#,index))))
'(expected ...)
(iota (length '(expected ...))))))
@ -84,6 +88,9 @@ (define (thunked-field? f)
(define (delayed-field? f)
(memq (syntax->datum f) 'delayed))
(define (innate-field? f)
(memq (syntax->datum f) 'innate))
(define (wrap-field-value f value)
(cond ((thunked-field? f)
#`(lambda () #,value))
@ -164,7 +171,8 @@ (define-record-type* <thing> thing make-thing
thing?
(name thing-name (default \"chbouib\"))
(port thing-port
(default (current-output-port)) (thunked)))
(default (current-output-port)) (thunked))
(loc thing-location (innate) (default (current-source-location))))
This example defines a macro 'thing' that can be used to instantiate records
of this type:
@ -190,7 +198,8 @@ (define-record-type* <thing> thing make-thing
(thing (inherit x) (name \"bar\"))
This expression returns a new object equal to 'x' except for its 'name'
field."
field and its 'loc' field---the latter is marked as \"innate\", so it is not
inherited."
(define (field-default-value s)
(syntax-case s (default)
@ -202,6 +211,7 @@ (define (field-default-value s)
(define-field-property-predicate delayed-field? delayed)
(define-field-property-predicate thunked-field? thunked)
(define-field-property-predicate innate-field? innate)
(define (wrapped-field? s)
(or (thunked-field? s) (delayed-field? s)))
@ -251,6 +261,7 @@ (define (delayed-field-accessor-definition field)
(let* ((field-spec #'((field get properties ...) ...))
(thunked (filter-map thunked-field? field-spec))
(delayed (filter-map delayed-field? field-spec))
(innate (filter-map innate-field? field-spec))
(defaults (filter-map field-default-value
#'((field properties ...) ...))))
(with-syntax (((field-spec* ...)
@ -278,6 +289,7 @@ (define-record-type type
(field ...)
#:thunked #,thunked
#:delayed #,delayed
#:innate #,innate
#:defaults #,defaults))))))))
(define* (alist->record alist make keys

30
tests/records.scm
View file

@ -90,6 +90,20 @@ (define-record-type* <foo> foo make-foo
(match b (($ <foo> 1 2) #t))
(equal? b c)))))
(test-assert "define-record-type* & inherit & innate"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar (innate) (default 42)))
(let* ((a (foo (bar 1)))
(b (foo (inherit a)))
(c (foo (inherit a) (bar 3)))
(d (foo)))
(and (match a (($ <foo> 1) #t))
(match b (($ <foo> 42) #t))
(match c (($ <foo> 3) #t))
(match d (($ <foo> 42) #t))))))
(test-assert "define-record-type* & thunked"
(begin
(define-record-type* <foo> foo make-foo
@ -139,6 +153,22 @@ (define-record-type* <foo> foo make-foo
(parameterize ((mark (cons 'a 'b)))
(eq? (foo-baz y) (mark))))))))
(test-assert "define-record-type* & thunked & innate"
(let ((mark (make-parameter #f)))
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar (thunked) (innate) (default (mark)))
(baz foo-baz (default #f)))
(let* ((x (foo (bar 42)))
(y (foo (inherit x) (baz 'unused))))
(and (procedure? (struct-ref x 0))
(equal? (foo-bar x) 42)
(parameterize ((mark (cons 'a 'b)))
(eq? (foo-bar y) (mark)))
(parameterize ((mark (cons 'a 'b)))
(eq? (foo-bar y) (mark)))))))
(test-assert "define-record-type* & delayed"
(begin
(define-record-type* <foo> foo make-foo