;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013, 2014, 2015, 2016 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
(parameterize ((mark (cons 'a 'b)))
(eq? (foo-bar y) (mark)))))))
+(test-assert "define-record-type* & thunked & this-record"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (thunked)))
+
+ (let ((x (foo (bar 40)
+ (baz (+ (foo-bar this-record) 2)))))
+ (and (= 40 (foo-bar x))
+ (= 42 (foo-baz x))))))
+
+(test-assert "define-record-type* & thunked & default & this-record"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (thunked)
+ (default (+ (foo-bar this-record) 2))))
+
+ (let ((x (foo (bar 40))))
+ (and (= 40 (foo-bar x))
+ (= 42 (foo-baz x))))))
+
+(test-assert "define-record-type* & thunked & inherit & this-record"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (thunked)
+ (default (+ (foo-bar this-record) 2))))
+
+ (let* ((x (foo (bar 40)))
+ (y (foo (inherit x) (bar -2)))
+ (z (foo (inherit x) (baz -2))))
+ (and (= -2 (foo-bar y))
+ (= 0 (foo-baz y))
+ (= 40 (foo-bar z))
+ (= -2 (foo-baz z))))))
+
+(test-assert "define-record-type* & thunked & inherit & custom this"
+ (let ()
+ (define-record-type* <foo> foo make-foo
+ foo? this-foo
+ (thing foo-thing (thunked)))
+ (define-record-type* <bar> bar make-bar
+ bar? this-bar
+ (baz bar-baz (thunked)))
+
+ ;; Nest records and test the two self references.
+ (let* ((x (foo (thing (bar (baz (list this-bar this-foo))))))
+ (y (foo-thing x)))
+ (match (bar-baz y)
+ ((first second)
+ (and (eq? second x)
+ (bar? first)
+ (eq? first y)))))))
+
(test-assert "define-record-type* & delayed"
(begin
(define-record-type* <foo> foo make-foo
(lambda ()
(eval exp (test-module))
#f)
- (lambda (key proc message location form . args)
+ (lambda (key proc message location form subform . _)
(and (eq? proc 'foo)
(string-match "invalid field" message)
- (equal? form '(baz 1 2 3 4 5))
+ (equal? subform '(baz 1 2 3 4 5))
+ (equal? form '(foo (baz 1 2 3 4 5)))
;; Make sure the location is that of the field specifier.
;; See <http://bugs.gnu.org/23969>.
,@(alist-delete 'line loc)))
(pk 'actual-loc location)))))))
+(test-assert "define-record-type* & wrong field specifier, identifier"
+ (let ((exp '(begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar (default 42))
+ (baz foo-baz))
+
+ (foo
+ baz))) ;syntax error
+ (loc (current-source-location))) ;keep this alignment!
+ (catch 'syntax-error
+ (lambda ()
+ (eval exp (test-module))
+ #f)
+ (lambda (key proc message location form subform . _)
+ (and (eq? proc 'foo)
+ (string-match "invalid field" message)
+ (equal? subform 'baz)
+ (equal? form '(foo baz))
+
+ ;; Here the location is that of the parent form.
+ (lset= equal?
+ (pk 'expected-loc
+ `((line . ,(- (assq-ref loc 'line) 2))
+ ,@(alist-delete 'line loc)))
+ (pk 'actual-loc location)))))))
+
(test-assert "define-record-type* & missing initializers"
(catch 'syntax-error
(lambda ()
(and (string-match "extra.*initializer.*baz" message)
(eq? proc 'foo)))))
+(test-assert "define-record-type* & duplicate initializers"
+ (let ((exp '(begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar (default 42)))
+
+ (foo (bar 1)
+ (bar 2))))
+ (loc (current-source-location))) ;keep this alignment!
+ (catch 'syntax-error
+ (lambda ()
+ (eval exp (test-module))
+ #f)
+ (lambda (key proc message location form . args)
+ (and (string-match "duplicate.*initializer" message)
+ (eq? proc 'foo)
+
+ ;; Make sure the location is that of the field specifier.
+ (lset= equal?
+ (pk 'expected-loc
+ `((line . ,(- (assq-ref loc 'line) 1))
+ ,@(alist-delete 'line loc)))
+ (pk 'actual-loc location)))))))
+
+(test-assert "ABI checks"
+ (let ((module (test-module)))
+ (eval '(begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar (default 42)))
+
+ (define (make-me-a-record) (foo)))
+ module)
+ (unless (eval '(foo? (make-me-a-record)) module)
+ (error "what?" (eval '(make-me-a-record) module)))
+
+ ;; Redefine <foo> with an additional field.
+ (eval '(define-record-type* <foo> foo make-foo
+ foo?
+ (baz foo-baz)
+ (bar foo-bar (default 42)))
+ module)
+
+ ;; Now 'make-me-a-record' is out of sync because it does an
+ ;; 'allocate-struct' that corresponds to the previous definition of <foo>.
+ (catch 'record-abi-mismatch-error
+ (lambda ()
+ (eval '(foo? (make-me-a-record)) module)
+ #f)
+ (match-lambda*
+ ((key 'abi-check (? string? message) (rtd) . _)
+ (eq? rtd (eval '<foo> module)))))))
+
(test-equal "recutils->alist"
'((("Name" . "foo")
("Version" . "0.1")
HCoop / jackhill / guix / guix.git / blobdiff