;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012, 2013 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.
;;;
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
(define-module (test-records)
+ #:use-module (srfi srfi-1)
#:use-module (srfi srfi-64)
#:use-module (ice-9 match)
+ #:use-module (ice-9 regex)
#:use-module (guix records))
+(define (test-module)
+ ;; A module in which to evaluate things that are known to fail.
+ (let ((module (make-fresh-user-module)))
+ (module-use! module (resolve-interface '(guix records)))
+ module))
+
+\f
(test-begin "records")
(test-assert "define-record-type*"
(match (foo (bar 1))
(($ <foo> 1 42) #t)))))
-(test-assert "define-record-type* with letrec* behavior"
+(test-assert "define-record-type* with let* behavior"
;; Make sure field initializers can refer to each other as if they were in
- ;; a `letrec*'.
+ ;; a 'let*'.
(begin
(define-record-type* <bar> bar make-bar
foo?
(and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
(($ <bar> 1 2 4) #t))
(match (bar (x 7) (z (* x 3)))
- (($ <bar> 7 42 21)))
+ (($ <bar> 7 42 21) #t))
(match (bar (z 21) (x (/ z 3)))
- (($ <bar> 7 42 21))))))
+ (($ <bar> 7 42 21) #t)))))
(test-assert "define-record-type* & inherit"
(begin
(equal? c d)
(match e (($ <foo> 42 77) #t))))))
-(test-assert "define-record-type* & inherit & letrec* behavior"
+(test-assert "define-record-type* & inherit & let* behavior"
(begin
(define-record-type* <foo> foo make-foo
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
(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* & 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
+ foo?
+ (bar foo-bar (delayed)))
+
+ (let* ((calls 0)
+ (x (foo (bar (begin (set! calls (1+ calls)) 3)))))
+ (and (zero? calls)
+ (equal? (foo-bar x) 3) (= 1 calls)
+ (equal? (foo-bar x) 3) (= 1 calls)
+ (equal? (foo-bar x) 3) (= 1 calls)))))
+
+(test-assert "define-record-type* & delayed & default"
+ (let ((mark #f))
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar (delayed) (default mark)))
+
+ (let ((x (foo)))
+ (set! mark 42)
+ (and (equal? (foo-bar x) 42)
+ (begin
+ (set! mark 7)
+ (equal? (foo-bar x) 42))))))
+
+(test-assert "define-record-type* & delayed & inherited"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar (delayed))
+ (baz foo-baz (delayed)))
+
+ (let* ((m 1)
+ (n #f)
+ (x (foo (bar m) (baz n)))
+ (y (foo (inherit x) (baz 'b))))
+ (set! n 'a)
+ (and (equal? (foo-bar x) 1)
+ (eq? (foo-baz x) 'a)
+ (begin
+ (set! m 777)
+ (equal? (foo-bar y) 1)) ;promise was already forced
+ (eq? (foo-baz y) 'b)))))
+
+(test-assert "define-record-type* & wrong field specifier"
+ (let ((exp '(begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar (default 42))
+ (baz foo-baz))
+
+ (foo (baz 1 2 3 4 5)))) ;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 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>.
+ (lset= equal?
+ (pk 'expected-loc
+ `((line . ,(- (assq-ref loc 'line) 1))
+ ,@(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 ()
+ (eval '(begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar (default 42))
+ (baz foo-baz))
+
+ (foo))
+ (test-module))
+ #f)
+ (lambda (key proc message location form . args)
+ (and (eq? proc 'foo)
+ (string-match "missing .*initialize.*baz" message)
+ (equal? form '(foo))))))
+
+(test-assert "define-record-type* & extra initializers"
+ (catch 'syntax-error
+ (lambda ()
+ (eval '(begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar (default 42)))
+
+ (foo (baz 'what?)))
+ (test-module))
+ #f)
+ (lambda (key proc message location form . args)
+ (and (string-match "extra.*initializer.*baz" message)
+ (eq? proc 'foo)))))
+
+(test-assert "define-record-type* & inherit & extra initializers"
+ (catch 'syntax-error
+ (lambda ()
+ (eval '(begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar (default 42)))
+
+ (foo (inherit (foo)) (baz 'what?)))
+ (test-module))
+ #f)
+ (lambda (key proc message location form . args)
+ (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")
'("a")))
(test-end)
-
-\f
-(exit (= (test-runner-fail-count (test-runner-current)) 0))
HCoop / jackhill / guix / guix.git / blobdiff