1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org>
4 ;;; This file is part of GNU Guix.
6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
7 ;;; under the terms of the GNU General Public License as published by
8 ;;; the Free Software Foundation; either version 3 of the License, or (at
9 ;;; your option) any later version.
11 ;;; GNU Guix is distributed in the hope that it will be useful, but
12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ;;; GNU General Public License for more details.
16 ;;; You should have received a copy of the GNU General Public License
17 ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
19 (define-module (test-records)
20 #:use-module (srfi srfi-1)
21 #:use-module (srfi srfi-64)
22 #:use-module (ice-9 match)
23 #:use-module (ice-9 regex)
24 #:use-module (guix records))
27 ;; A module in which to evaluate things that are known to fail.
28 (let ((module (make-fresh-user-module)))
29 (module-use! module (resolve-interface '(guix records)))
33 (test-begin "records")
35 (test-assert "define-record-type*"
37 (define-record-type* <foo> foo make-foo
40 (baz foo-baz (default (+ 40 2))))
41 (and (match (foo (bar 1) (baz 2))
43 (match (foo (baz 2) (bar 1))
46 (($ <foo> 1 42) #t)))))
48 (test-assert "define-record-type* with let* behavior"
49 ;; Make sure field initializers can refer to each other as if they were in
52 (define-record-type* <bar> bar make-bar
55 (y bar-y (default (+ 40 2)))
57 (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
59 (match (bar (x 7) (z (* x 3)))
60 (($ <bar> 7 42 21) #t))
61 (match (bar (z 21) (x (/ z 3)))
62 (($ <bar> 7 42 21) #t)))))
64 (test-assert "define-record-type* & inherit"
66 (define-record-type* <foo> foo make-foo
69 (baz foo-baz (default (+ 40 2))))
70 (let* ((a (foo (bar 1)))
71 (b (foo (inherit a) (baz 2)))
72 (c (foo (inherit b) (bar -2)))
74 (e (foo (inherit (foo (bar 42))) (baz 77))))
75 (and (match a (($ <foo> 1 42) #t))
76 (match b (($ <foo> 1 2) #t))
77 (match c (($ <foo> -2 2) #t))
79 (match e (($ <foo> 42 77) #t))))))
81 (test-assert "define-record-type* & inherit & let* behavior"
83 (define-record-type* <foo> foo make-foo
86 (baz foo-baz (default (+ 40 2))))
87 (let* ((a (foo (bar 77)))
88 (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
89 (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
90 (and (match a (($ <foo> 77 42) #t))
91 (match b (($ <foo> 1 2) #t))
94 (test-assert "define-record-type* & inherit & innate"
96 (define-record-type* <foo> foo make-foo
98 (bar foo-bar (innate) (default 42)))
99 (let* ((a (foo (bar 1)))
100 (b (foo (inherit a)))
101 (c (foo (inherit a) (bar 3)))
103 (and (match a (($ <foo> 1) #t))
104 (match b (($ <foo> 42) #t))
105 (match c (($ <foo> 3) #t))
106 (match d (($ <foo> 42) #t))))))
108 (test-assert "define-record-type* & thunked"
110 (define-record-type* <foo> foo make-foo
113 (baz foo-baz (thunked)))
117 (baz (begin (set! calls (1+ calls)) 3)))))
119 (equal? (foo-bar x) 2)
120 (equal? (foo-baz x) 3) (= 1 calls)
121 (equal? (foo-baz x) 3) (= 2 calls)))))
123 (test-assert "define-record-type* & thunked & default"
125 (define-record-type* <foo> foo make-foo
128 (baz foo-baz (thunked) (default 42)))
130 (let ((mark (make-parameter #f)))
131 (let ((x (foo (bar 2) (baz (mark))))
133 (and (equal? (foo-bar x) 2)
134 (parameterize ((mark (cons 'a 'b)))
135 (eq? (foo-baz x) (mark)))
136 (equal? (foo-bar y) 2)
137 (equal? (foo-baz y) 42))))))
139 (test-assert "define-record-type* & thunked & inherited"
141 (define-record-type* <foo> foo make-foo
143 (bar foo-bar (thunked))
144 (baz foo-baz (thunked) (default 42)))
146 (let ((mark (make-parameter #f)))
147 (let* ((x (foo (bar 2) (baz (mark))))
148 (y (foo (inherit x) (bar (mark)))))
149 (and (equal? (foo-bar x) 2)
150 (parameterize ((mark (cons 'a 'b)))
151 (eq? (foo-baz x) (mark)))
152 (parameterize ((mark (cons 'a 'b)))
153 (eq? (foo-bar y) (mark)))
154 (parameterize ((mark (cons 'a 'b)))
155 (eq? (foo-baz y) (mark))))))))
157 (test-assert "define-record-type* & thunked & innate"
158 (let ((mark (make-parameter #f)))
159 (define-record-type* <foo> foo make-foo
161 (bar foo-bar (thunked) (innate) (default (mark)))
162 (baz foo-baz (default #f)))
164 (let* ((x (foo (bar 42)))
165 (y (foo (inherit x) (baz 'unused))))
166 (and (procedure? (struct-ref x 0))
167 (equal? (foo-bar x) 42)
168 (parameterize ((mark (cons 'a 'b)))
169 (eq? (foo-bar y) (mark)))
170 (parameterize ((mark (cons 'a 'b)))
171 (eq? (foo-bar y) (mark)))))))
173 (test-assert "define-record-type* & thunked & this-record"
175 (define-record-type* <foo> foo make-foo
178 (baz foo-baz (thunked)))
180 (let ((x (foo (bar 40)
181 (baz (+ (foo-bar this-record) 2)))))
182 (and (= 40 (foo-bar x))
183 (= 42 (foo-baz x))))))
185 (test-assert "define-record-type* & thunked & default & this-record"
187 (define-record-type* <foo> foo make-foo
190 (baz foo-baz (thunked)
191 (default (+ (foo-bar this-record) 2))))
193 (let ((x (foo (bar 40))))
194 (and (= 40 (foo-bar x))
195 (= 42 (foo-baz x))))))
197 (test-assert "define-record-type* & thunked & inherit & this-record"
199 (define-record-type* <foo> foo make-foo
202 (baz foo-baz (thunked)
203 (default (+ (foo-bar this-record) 2))))
205 (let* ((x (foo (bar 40)))
206 (y (foo (inherit x) (bar -2)))
207 (z (foo (inherit x) (baz -2))))
208 (and (= -2 (foo-bar y))
211 (= -2 (foo-baz z))))))
213 (test-assert "define-record-type* & thunked & inherit & custom this"
215 (define-record-type* <foo> foo make-foo
217 (thing foo-thing (thunked)))
218 (define-record-type* <bar> bar make-bar
220 (baz bar-baz (thunked)))
222 ;; Nest records and test the two self references.
223 (let* ((x (foo (thing (bar (baz (list this-bar this-foo))))))
231 (test-assert "define-record-type* & delayed"
233 (define-record-type* <foo> foo make-foo
235 (bar foo-bar (delayed)))
238 (x (foo (bar (begin (set! calls (1+ calls)) 3)))))
240 (equal? (foo-bar x) 3) (= 1 calls)
241 (equal? (foo-bar x) 3) (= 1 calls)
242 (equal? (foo-bar x) 3) (= 1 calls)))))
244 (test-assert "define-record-type* & delayed & default"
246 (define-record-type* <foo> foo make-foo
248 (bar foo-bar (delayed) (default mark)))
252 (and (equal? (foo-bar x) 42)
255 (equal? (foo-bar x) 42))))))
257 (test-assert "define-record-type* & delayed & inherited"
259 (define-record-type* <foo> foo make-foo
261 (bar foo-bar (delayed))
262 (baz foo-baz (delayed)))
266 (x (foo (bar m) (baz n)))
267 (y (foo (inherit x) (baz 'b))))
269 (and (equal? (foo-bar x) 1)
273 (equal? (foo-bar y) 1)) ;promise was already forced
274 (eq? (foo-baz y) 'b)))))
276 (test-assert "define-record-type* & wrong field specifier"
278 (define-record-type* <foo> foo make-foo
280 (bar foo-bar (default 42))
283 (foo (baz 1 2 3 4 5)))) ;syntax error
284 (loc (current-source-location))) ;keep this alignment!
287 (eval exp (test-module))
289 (lambda (key proc message location form subform . _)
291 (string-match "invalid field" message)
292 (equal? subform '(baz 1 2 3 4 5))
293 (equal? form '(foo (baz 1 2 3 4 5)))
295 ;; Make sure the location is that of the field specifier.
296 ;; See <http://bugs.gnu.org/23969>.
299 `((line . ,(- (assq-ref loc 'line) 1))
300 ,@(alist-delete 'line loc)))
301 (pk 'actual-loc location)))))))
303 (test-assert "define-record-type* & wrong field specifier, identifier"
305 (define-record-type* <foo> foo make-foo
307 (bar foo-bar (default 42))
312 (loc (current-source-location))) ;keep this alignment!
315 (eval exp (test-module))
317 (lambda (key proc message location form subform . _)
319 (string-match "invalid field" message)
320 (equal? subform 'baz)
321 (equal? form '(foo baz))
323 ;; Here the location is that of the parent form.
326 `((line . ,(- (assq-ref loc 'line) 2))
327 ,@(alist-delete 'line loc)))
328 (pk 'actual-loc location)))))))
330 (test-assert "define-record-type* & missing initializers"
334 (define-record-type* <foo> foo make-foo
336 (bar foo-bar (default 42))
342 (lambda (key proc message location form . args)
344 (string-match "missing .*initialize.*baz" message)
345 (equal? form '(foo))))))
347 (test-assert "define-record-type* & extra initializers"
351 (define-record-type* <foo> foo make-foo
353 (bar foo-bar (default 42)))
358 (lambda (key proc message location form . args)
359 (and (string-match "extra.*initializer.*baz" message)
362 (test-assert "define-record-type* & inherit & extra initializers"
366 (define-record-type* <foo> foo make-foo
368 (bar foo-bar (default 42)))
370 (foo (inherit (foo)) (baz 'what?)))
373 (lambda (key proc message location form . args)
374 (and (string-match "extra.*initializer.*baz" message)
377 (test-assert "define-record-type* & duplicate initializers"
379 (define-record-type* <foo> foo make-foo
381 (bar foo-bar (default 42)))
385 (loc (current-source-location))) ;keep this alignment!
388 (eval exp (test-module))
390 (lambda (key proc message location form . args)
391 (and (string-match "duplicate.*initializer" message)
394 ;; Make sure the location is that of the field specifier.
397 `((line . ,(- (assq-ref loc 'line) 1))
398 ,@(alist-delete 'line loc)))
399 (pk 'actual-loc location)))))))
401 (test-assert "ABI checks"
402 (let ((module (test-module)))
404 (define-record-type* <foo> foo make-foo
406 (bar foo-bar (default 42)))
408 (define (make-me-a-record) (foo)))
410 (unless (eval '(foo? (make-me-a-record)) module)
411 (error "what?" (eval '(make-me-a-record) module)))
413 ;; Redefine <foo> with an additional field.
414 (eval '(define-record-type* <foo> foo make-foo
417 (bar foo-bar (default 42)))
420 ;; Now 'make-me-a-record' is out of sync because it does an
421 ;; 'allocate-struct' that corresponds to the previous definition of <foo>.
422 (catch 'record-abi-mismatch-error
424 (eval '(foo? (make-me-a-record)) module)
427 ((key 'abi-check (? string? message) (rtd) . _)
428 (eq? rtd (eval '<foo> module)))))))
430 (test-equal "recutils->alist"
433 ("Synopsis" . "foo bar")
434 ("Something_else" . "chbouib"))
436 ("Version" . "1.5")))
437 (let ((p (open-input-string "
438 # Comment following an empty line, and
439 # preceding a couple of empty lines, all of
440 # which should be silently consumed.
445 # Comment right in the middle,
446 # spanning two lines.
448 Something_else: chbouib
450 # Comment right before.
453 # Comment at the end.")))
454 (list (recutils->alist p)
455 (recutils->alist p))))
457 (test-equal "recutils->alist with + lines"
459 ("Description" . "1st line,\n2nd line,\n 3rd line with extra space,\n4th line without space."))
460 (recutils->alist (open-input-string "
462 Description: 1st line,
464 + 3rd line with extra space,
465 +4th line without space.")))
467 (test-equal "alist->record" '((1 2) b c)
468 (alist->record '(("a" . 1) ("b" . b) ("c" . c) ("a" . 2))