X-Git-Url: http://git.hcoop.net/jackhill/guix/guix.git/blobdiff_plain/a9edb211e733b8b34e67ec3b4450567e9376986f..66016b1ae01423bc0671cc39992263520fd77998:/tests/records.scm diff --git a/tests/records.scm b/tests/records.scm index c6f85d4a81..2c55a61720 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès +;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,6 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (test-records) + #:use-module (srfi srfi-1) #:use-module (srfi srfi-64) #:use-module (ice-9 match) #:use-module (ice-9 regex) @@ -169,6 +170,64 @@ (parameterize ((mark (cons 'a 'b))) (eq? (foo-bar y) (mark))))))) +(test-assert "define-record-type* & thunked & this-record" + (begin + (define-record-type* 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 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 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 make-foo + foo? this-foo + (thing foo-thing (thunked))) + (define-record-type* 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 make-foo @@ -214,6 +273,60 @@ (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 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 . + (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 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 () @@ -261,6 +374,59 @@ (and (string-match "extra.*initializer.*baz" message) (eq? proc 'foo))))) +(test-assert "define-record-type* & duplicate initializers" + (let ((exp '(begin + (define-record-type* 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 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 with an additional field. + (eval '(define-record-type* 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 . + (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 ' module))))))) + (test-equal "recutils->alist" '((("Name" . "foo") ("Version" . "0.1")