1;;;; records.test --- Test suite for Guile's records. -*- mode: scheme; coding: utf-8 -*-
2;;;;
3;;;; Copyright (C) 2009-2010, 2019 Free Software Foundation, Inc.
4;;;;
5;;;; This library is free software; you can redistribute it and/or
6;;;; modify it under the terms of the GNU Lesser General Public
7;;;; License as published by the Free Software Foundation; either
8;;;; version 3 of the License, or (at your option) any later version.
9;;;;
10;;;; This library is distributed in the hope that it will be useful,
11;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
13;;;; Lesser General Public License for more details.
14;;;;
15;;;; You should have received a copy of the GNU Lesser General Public
16;;;; License along with this library; if not, write to the Free Software
17;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
18
19(define-module (test-records)
20  #:use-module (ice-9 format)
21  #:use-module (test-suite lib))
22
23;; ascii names and symbols, custom printer
24(define rtd-foo (make-record-type 'foo '(x y)
25                                  (lambda (s p)
26                                    (display "#<it is a foo>" p))))
27(define make-foo (record-constructor rtd-foo))
28(define foo? (record-predicate rtd-foo))
29(define get-foo-x (record-accessor rtd-foo 'x))
30(define get-foo-y (record-accessor rtd-foo 'y))
31(define set-foo-x! (record-modifier rtd-foo 'x))
32(define set-foo-y! (record-modifier rtd-foo 'y))
33
34;; non-Latin-1 names and symbols, default printer
35(define rtd-fŏŏ (make-record-type 'fŏŏ '(x ȳ)))
36(define make-fŏŏ (record-constructor rtd-fŏŏ))
37(define fŏŏ? (record-predicate rtd-fŏŏ))
38(define get-fŏŏ-x (record-accessor rtd-fŏŏ 'x))
39(define get-fŏŏ-ȳ (record-accessor rtd-fŏŏ 'ȳ))
40(define set-fŏŏ-x! (record-modifier rtd-fŏŏ 'x))
41(define set-fŏŏ-ȳ! (record-modifier rtd-fŏŏ 'ȳ))
42
43(with-test-prefix "records"
44
45  (with-test-prefix "constructor"
46
47    (pass-if-exception "0 args (2 required)" exception:wrong-num-args
48      (make-foo))
49
50    (pass-if-exception "1 arg (2 required)" exception:wrong-num-args
51      (make-foo 1))
52
53    (pass-if "2 args (2 required)" exception:wrong-num-args
54      (foo? (make-foo 1 2)))
55
56    (pass-if "non-latin-1" exception:wrong-num-args
57      (fŏŏ? (make-fŏŏ 1 2))))
58
59  (with-test-prefix "modifier and getter"
60
61    (pass-if "set"
62      (let ((r (make-foo 1 2)))
63        (set-foo-x! r 3)
64        (eqv? (get-foo-x r) 3)))
65
66    (pass-if "set 2"
67      (let ((r (make-fŏŏ 1 2)))
68        (set-fŏŏ-ȳ! r 3)
69        (eqv? (get-fŏŏ-ȳ r) 3))))
70
71  (with-test-prefix "record type name"
72
73    (pass-if "foo"
74      (string=? "foo" (symbol->string (record-type-name rtd-foo))))
75
76    (pass-if "fŏŏ"
77      (string=? "fŏŏ" (symbol->string (record-type-name rtd-fŏŏ)))))
78
79  (with-test-prefix "printer"
80
81    (pass-if "foo"
82      (string=? "#<it is a foo>"
83                (with-output-to-string
84                  (lambda () (display (make-foo 1 2))))))
85
86    (pass-if "fŏŏ"
87      (with-locale "en_US.utf8"
88        (string-prefix? "#<fŏŏ"
89                        (with-output-to-string
90                          (lambda () (display (make-fŏŏ 1 2))))))))
91
92  (with-test-prefix "subtyping"
93    (let ()
94      (define a (make-record-type 'a '(s t)))
95      (define b (make-record-type 'b '(u v) #:extensible? #t))
96      (define c (make-record-type 'c '(w x) #:parent b))
97
98      (pass-if (not (record-type-extensible? a)))
99      (pass-if (record-type-extensible? b))
100      (pass-if (not (record-type-extensible? c)))
101
102      (pass-if-exception "subtyping final: a" '(misc-error . "final")
103        (make-record-type 'd '(y x) #:parent a))
104      (pass-if-exception "subtyping final: c" '(misc-error . "final")
105        (make-record-type 'd '(y x) #:parent c))
106
107      (pass-if-equal "fields of subtype" '(u v w x)
108        (record-type-fields c))
109
110      (pass-if "final predicate: a? a"
111        ((record-predicate a) ((record-constructor a) 1 2)))
112      (pass-if "final predicate: a? b"
113        (not ((record-predicate a) ((record-constructor b) 1 2))))
114
115      (pass-if "non-final predicate: b? a"
116        (not ((record-predicate b) ((record-constructor a) 1 2))))
117      (pass-if "non-final predicate: b? b"
118        ((record-predicate b) ((record-constructor b) 1 2)))
119      (pass-if "non-final predicate: b? c"
120        ((record-predicate b) ((record-constructor c) 1 2 3 4)))
121
122      (pass-if "final predicate: c? a"
123        (not ((record-predicate c) ((record-constructor a) 1 2))))
124      (pass-if "final predicate: c? b"
125        (not ((record-predicate c) ((record-constructor b) 1 2))))
126      (pass-if "final predicate: c? c"
127        ((record-predicate c) ((record-constructor c) 1 2 3 4)))
128
129      (pass-if-equal "b accessor on b" 1
130        ((record-accessor b 'u) ((record-constructor b) 1 2)))
131      (pass-if-equal "b accessor on c" 1
132        ((record-accessor b 'u) ((record-constructor c) 1 2 3 4)))
133
134      (pass-if-equal "c accessor on c" 3
135        ((record-accessor c 'w) ((record-constructor c) 1 2 3 4)))))
136
137  (with-test-prefix "prefab types"
138    (let ()
139      (define uid 'ANhUpf2WpNnF2XIVLxq@IkavIc5wbqe8)
140      (define a (make-record-type 'a '(s t) #:uid uid))
141      (define b (make-record-type 'b '() #:extensible? #t))
142
143      (pass-if (eq? a (make-record-type 'a '(s t) #:uid uid)))
144      (pass-if-exception "different name" '(misc-error . "incompatible")
145        (make-record-type 'b '(s t) #:uid uid))
146      (pass-if-exception "different fields" '(misc-error . "incompatible")
147        (make-record-type 'a '(u v) #:uid uid))
148      (pass-if-exception "fewer fields" '(misc-error . "incompatible")
149        (make-record-type 'a '(s) #:uid uid))
150      (pass-if-exception "more fields" '(misc-error . "incompatible")
151        (make-record-type 'a '(s t u) #:uid uid))
152      (pass-if-exception "adding a parent" '(misc-error . "incompatible")
153        (make-record-type 'a '(s t) #:parent b #:uid uid))
154      (pass-if-exception "specifying a printer" '(misc-error . "incompatible")
155        (make-record-type 'a '(s t) pk #:uid uid))
156      (pass-if-exception "non-final" '(misc-error . "incompatible")
157        (make-record-type 'a '(s t) #:extensible? #t #:uid uid))))
158
159  (with-test-prefix "opaque types"
160    (let ()
161      (define a (make-record-type 'a '() #:extensible? #t #:opaque? #t))
162      (define b (make-record-type 'b '()))
163      (define c (make-record-type 'c '() #:parent a))
164
165      (pass-if (record-type-opaque? a))
166      (pass-if (not (record-type-opaque? b)))
167      (pass-if (record-type-opaque? c))
168      (pass-if-exception "non-opaque" '(misc-error . "opaque")
169        (make-record-type 'd '() #:opaque? #f #:parent a))))
170
171  (with-test-prefix "immutable fields"
172    (let ()
173      (define a (make-record-type 'a '(s t (mutable u) (immutable v))
174                                  #:extensible? #t))
175      (define b (make-record-type 'b '(w (immutable x)) #:parent a))
176
177      (pass-if-exception "bad field" '(misc-error . "field")
178        (make-record-type 'a '("foo")))
179      (pass-if-exception "bad field" '(misc-error . "field")
180        (make-record-type 'a '((mutable u x))))
181      (pass-if-exception "bad field" '(misc-error . "field")
182        (make-record-type 'a '((qux u))))
183      (pass-if-equal (record-type-mutable-fields a) #b0111)
184      (pass-if-equal (record-type-mutable-fields b) #b010111)
185
186      (pass-if (procedure? (record-modifier a 's)))
187      (pass-if (procedure? (record-modifier a 't)))
188      (pass-if (procedure? (record-modifier a 'u)))
189      (pass-if-exception "immutable" '(misc-error . "immutable")
190        (record-modifier a 'v))
191
192      (pass-if (procedure? (record-modifier b 's)))
193      (pass-if (procedure? (record-modifier b 't)))
194      (pass-if (procedure? (record-modifier b 'u)))
195      (pass-if-exception "immutable" '(misc-error . "immutable")
196        (record-modifier b 'v))
197      (pass-if (procedure? (record-modifier b 'w)))
198      (pass-if-exception "immutable" '(misc-error . "immutable")
199        (record-modifier b 'x)))))
200