records: Report unknown field names in inheriting forms.
[jackhill/guix/guix.git] / tests / records.scm
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014 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 (ice-9 regex)
23 #:use-module (guix records))
24
25 (define (test-module)
26 ;; A module in which to evaluate things that are known to fail.
27 (let ((module (make-fresh-user-module)))
28 (module-use! module (resolve-interface '(guix records)))
29 module))
30
31 \f
32 (test-begin "records")
33
34 (test-assert "define-record-type*"
35 (begin
36 (define-record-type* <foo> foo make-foo
37 foo?
38 (bar foo-bar)
39 (baz foo-baz (default (+ 40 2))))
40 (and (match (foo (bar 1) (baz 2))
41 (($ <foo> 1 2) #t))
42 (match (foo (baz 2) (bar 1))
43 (($ <foo> 1 2) #t))
44 (match (foo (bar 1))
45 (($ <foo> 1 42) #t)))))
46
47 (test-assert "define-record-type* with let* behavior"
48 ;; Make sure field initializers can refer to each other as if they were in
49 ;; a 'let*'.
50 (begin
51 (define-record-type* <bar> bar make-bar
52 foo?
53 (x bar-x)
54 (y bar-y (default (+ 40 2)))
55 (z bar-z))
56 (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
57 (($ <bar> 1 2 4) #t))
58 (match (bar (x 7) (z (* x 3)))
59 (($ <bar> 7 42 21)))
60 (match (bar (z 21) (x (/ z 3)))
61 (($ <bar> 7 42 21) #t)))))
62
63 (test-assert "define-record-type* & inherit"
64 (begin
65 (define-record-type* <foo> foo make-foo
66 foo?
67 (bar foo-bar)
68 (baz foo-baz (default (+ 40 2))))
69 (let* ((a (foo (bar 1)))
70 (b (foo (inherit a) (baz 2)))
71 (c (foo (inherit b) (bar -2)))
72 (d (foo (inherit c)))
73 (e (foo (inherit (foo (bar 42))) (baz 77))))
74 (and (match a (($ <foo> 1 42) #t))
75 (match b (($ <foo> 1 2) #t))
76 (match c (($ <foo> -2 2) #t))
77 (equal? c d)
78 (match e (($ <foo> 42 77) #t))))))
79
80 (test-assert "define-record-type* & inherit & let* behavior"
81 (begin
82 (define-record-type* <foo> foo make-foo
83 foo?
84 (bar foo-bar)
85 (baz foo-baz (default (+ 40 2))))
86 (let* ((a (foo (bar 77)))
87 (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
88 (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
89 (and (match a (($ <foo> 77 42) #t))
90 (match b (($ <foo> 1 2) #t))
91 (equal? b c)))))
92
93 (test-assert "define-record-type* & thunked"
94 (begin
95 (define-record-type* <foo> foo make-foo
96 foo?
97 (bar foo-bar)
98 (baz foo-baz (thunked)))
99
100 (let* ((calls 0)
101 (x (foo (bar 2)
102 (baz (begin (set! calls (1+ calls)) 3)))))
103 (and (zero? calls)
104 (equal? (foo-bar x) 2)
105 (equal? (foo-baz x) 3) (= 1 calls)
106 (equal? (foo-baz x) 3) (= 2 calls)))))
107
108 (test-assert "define-record-type* & thunked & default"
109 (begin
110 (define-record-type* <foo> foo make-foo
111 foo?
112 (bar foo-bar)
113 (baz foo-baz (thunked) (default 42)))
114
115 (let ((mark (make-parameter #f)))
116 (let ((x (foo (bar 2) (baz (mark))))
117 (y (foo (bar 2))))
118 (and (equal? (foo-bar x) 2)
119 (parameterize ((mark (cons 'a 'b)))
120 (eq? (foo-baz x) (mark)))
121 (equal? (foo-bar y) 2)
122 (equal? (foo-baz y) 42))))))
123
124 (test-assert "define-record-type* & thunked & inherited"
125 (begin
126 (define-record-type* <foo> foo make-foo
127 foo?
128 (bar foo-bar (thunked))
129 (baz foo-baz (thunked) (default 42)))
130
131 (let ((mark (make-parameter #f)))
132 (let* ((x (foo (bar 2) (baz (mark))))
133 (y (foo (inherit x) (bar (mark)))))
134 (and (equal? (foo-bar x) 2)
135 (parameterize ((mark (cons 'a 'b)))
136 (eq? (foo-baz x) (mark)))
137 (parameterize ((mark (cons 'a 'b)))
138 (eq? (foo-bar y) (mark)))
139 (parameterize ((mark (cons 'a 'b)))
140 (eq? (foo-baz y) (mark))))))))
141
142 (test-assert "define-record-type* & missing initializers"
143 (catch 'syntax-error
144 (lambda ()
145 (eval '(begin
146 (define-record-type* <foo> foo make-foo
147 foo?
148 (bar foo-bar (default 42))
149 (baz foo-baz))
150
151 (foo))
152 (test-module))
153 #f)
154 (lambda (key proc message location form . args)
155 (and (eq? proc 'foo)
156 (string-match "missing .*initialize.*baz" message)
157 (equal? form '(foo))))))
158
159 (test-assert "define-record-type* & extra initializers"
160 (catch 'syntax-error
161 (lambda ()
162 (eval '(begin
163 (define-record-type* <foo> foo make-foo
164 foo?
165 (bar foo-bar (default 42)))
166
167 (foo (baz 'what?)))
168 (test-module))
169 #f)
170 (lambda (key proc message location form . args)
171 (and (string-match "extra.*initializer.*baz" message)
172 (eq? proc 'foo)))))
173
174 (test-assert "define-record-type* & inherit & extra initializers"
175 (catch 'syntax-error
176 (lambda ()
177 (eval '(begin
178 (define-record-type* <foo> foo make-foo
179 foo?
180 (bar foo-bar (default 42)))
181
182 (foo (inherit (foo)) (baz 'what?)))
183 (test-module))
184 #f)
185 (lambda (key proc message location form . args)
186 (and (string-match "extra.*initializer.*baz" message)
187 (eq? proc 'foo)))))
188
189 (test-equal "recutils->alist"
190 '((("Name" . "foo")
191 ("Version" . "0.1")
192 ("Synopsis" . "foo bar")
193 ("Something_else" . "chbouib"))
194 (("Name" . "bar")
195 ("Version" . "1.5")))
196 (let ((p (open-input-string "
197 # Comment following an empty line, and
198 # preceding a couple of empty lines, all of
199 # which should be silently consumed.
200
201
202 Name: foo
203 Version: 0.1
204 # Comment right in the middle,
205 # spanning two lines.
206 Synopsis: foo bar
207 Something_else: chbouib
208
209 # Comment right before.
210 Name: bar
211 Version: 1.5
212 # Comment at the end.")))
213 (list (recutils->alist p)
214 (recutils->alist p))))
215
216 (test-equal "recutils->alist with + lines"
217 '(("Name" . "foo")
218 ("Description" . "1st line,\n2nd line,\n 3rd line with extra space,\n4th line without space."))
219 (recutils->alist (open-input-string "
220 Name: foo
221 Description: 1st line,
222 + 2nd line,
223 + 3rd line with extra space,
224 +4th line without space.")))
225
226 (test-equal "alist->record" '((1 2) b c)
227 (alist->record '(("a" . 1) ("b" . b) ("c" . c) ("a" . 2))
228 list
229 '("a" "b" "c")
230 '("a")))
231
232 (test-end)
233
234 \f
235 (exit (= (test-runner-fail-count (test-runner-current)) 0))