Commit | Line | Data |
---|---|---|
c0cd1b3e LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org> | |
3 | ;;; | |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
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. | |
10 | ;;; | |
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. | |
15 | ;;; | |
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/>. | |
18 | ||
19 | (define-module (test-records) | |
20 | #:use-module (srfi srfi-64) | |
21 | #:use-module (ice-9 match) | |
22 | #:use-module (guix records)) | |
23 | ||
24 | (test-begin "records") | |
25 | ||
26 | (test-assert "define-record-type*" | |
27 | (begin | |
28 | (define-record-type* <foo> foo make-foo | |
29 | foo? | |
30 | (bar foo-bar) | |
31 | (baz foo-baz (default (+ 40 2)))) | |
32 | (and (match (foo (bar 1) (baz 2)) | |
33 | (($ <foo> 1 2) #t)) | |
34 | (match (foo (baz 2) (bar 1)) | |
35 | (($ <foo> 1 2) #t)) | |
36 | (match (foo (bar 1)) | |
37 | (($ <foo> 1 42) #t))))) | |
38 | ||
39 | (test-assert "define-record-type* with letrec* behavior" | |
40 | ;; Make sure field initializers can refer to each other as if they were in | |
41 | ;; a `letrec*'. | |
42 | (begin | |
43 | (define-record-type* <bar> bar make-bar | |
44 | foo? | |
45 | (x bar-x) | |
46 | (y bar-y (default (+ 40 2))) | |
47 | (z bar-z)) | |
48 | (and (match (bar (x 1) (y (+ x 1)) (z (* y 2))) | |
49 | (($ <bar> 1 2 4) #t)) | |
50 | (match (bar (x 7) (z (* x 3))) | |
51 | (($ <bar> 7 42 21))) | |
52 | (match (bar (z 21) (x (/ z 3))) | |
53 | (($ <bar> 7 42 21)))))) | |
54 | ||
55 | (test-assert "define-record-type* & inherit" | |
56 | (begin | |
57 | (define-record-type* <foo> foo make-foo | |
58 | foo? | |
59 | (bar foo-bar) | |
60 | (baz foo-baz (default (+ 40 2)))) | |
61 | (let* ((a (foo (bar 1))) | |
62 | (b (foo (inherit a) (baz 2))) | |
63 | (c (foo (inherit b) (bar -2))) | |
64 | (d (foo (inherit c))) | |
65 | (e (foo (inherit (foo (bar 42))) (baz 77)))) | |
66 | (and (match a (($ <foo> 1 42) #t)) | |
67 | (match b (($ <foo> 1 2) #t)) | |
68 | (match c (($ <foo> -2 2) #t)) | |
69 | (equal? c d) | |
70 | (match e (($ <foo> 42 77) #t)))))) | |
71 | ||
72 | (test-assert "define-record-type* & inherit & letrec* behavior" | |
73 | (begin | |
74 | (define-record-type* <foo> foo make-foo | |
75 | foo? | |
76 | (bar foo-bar) | |
77 | (baz foo-baz (default (+ 40 2)))) | |
78 | (let* ((a (foo (bar 77))) | |
79 | (b (foo (inherit a) (bar 1) (baz (+ bar 1)))) | |
80 | (c (foo (inherit b) (baz 2) (bar (- baz 1))))) | |
81 | (and (match a (($ <foo> 77 42) #t)) | |
82 | (match b (($ <foo> 1 2) #t)) | |
83 | (equal? b c))))) | |
84 | ||
85 | (test-assert "define-record-type* & thunked" | |
86 | (begin | |
87 | (define-record-type* <foo> foo make-foo | |
88 | foo? | |
89 | (bar foo-bar) | |
90 | (baz foo-baz (thunked))) | |
91 | ||
92 | (let* ((calls 0) | |
93 | (x (foo (bar 2) | |
94 | (baz (begin (set! calls (1+ calls)) 3))))) | |
95 | (and (zero? calls) | |
96 | (equal? (foo-bar x) 2) | |
97 | (equal? (foo-baz x) 3) (= 1 calls) | |
98 | (equal? (foo-baz x) 3) (= 2 calls))))) | |
99 | ||
100 | (test-assert "define-record-type* & thunked & default" | |
101 | (begin | |
102 | (define-record-type* <foo> foo make-foo | |
103 | foo? | |
104 | (bar foo-bar) | |
105 | (baz foo-baz (thunked) (default 42))) | |
106 | ||
107 | (let ((mark (make-parameter #f))) | |
108 | (let ((x (foo (bar 2) (baz (mark)))) | |
109 | (y (foo (bar 2)))) | |
110 | (and (equal? (foo-bar x) 2) | |
111 | (parameterize ((mark (cons 'a 'b))) | |
112 | (eq? (foo-baz x) (mark))) | |
113 | (equal? (foo-bar y) 2) | |
114 | (equal? (foo-baz y) 42)))))) | |
115 | ||
116 | (test-assert "define-record-type* & thunked & inherited" | |
117 | (begin | |
118 | (define-record-type* <foo> foo make-foo | |
119 | foo? | |
120 | (bar foo-bar (thunked)) | |
121 | (baz foo-baz (thunked) (default 42))) | |
122 | ||
123 | (let ((mark (make-parameter #f))) | |
124 | (let* ((x (foo (bar 2) (baz (mark)))) | |
125 | (y (foo (inherit x) (bar (mark))))) | |
126 | (and (equal? (foo-bar x) 2) | |
127 | (parameterize ((mark (cons 'a 'b))) | |
128 | (eq? (foo-baz x) (mark))) | |
129 | (parameterize ((mark (cons 'a 'b))) | |
130 | (eq? (foo-bar y) (mark))) | |
131 | (parameterize ((mark (cons 'a 'b))) | |
132 | (eq? (foo-baz y) (mark)))))))) | |
133 | ||
134 | (test-end) | |
135 | ||
136 | \f | |
137 | (exit (= (test-runner-fail-count (test-runner-current)) 0)) |