1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015 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-64)
21 #:use-module (ice-9 match)
22 #:use-module (ice-9 regex)
23 #:use-module (guix records))
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)))
32 (test-begin "records")
34 (test-assert "define-record-type*"
36 (define-record-type* <foo> foo make-foo
39 (baz foo-baz (default (+ 40 2))))
40 (and (match (foo (bar 1) (baz 2))
42 (match (foo (baz 2) (bar 1))
45 (($ <foo> 1 42) #t)))))
47 (test-assert "define-record-type* with let* behavior"
48 ;; Make sure field initializers can refer to each other as if they were in
51 (define-record-type* <bar> bar make-bar
54 (y bar-y (default (+ 40 2)))
56 (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
58 (match (bar (x 7) (z (* x 3)))
60 (match (bar (z 21) (x (/ z 3)))
61 (($ <bar> 7 42 21) #t)))))
63 (test-assert "define-record-type* & inherit"
65 (define-record-type* <foo> foo make-foo
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)))
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))
78 (match e (($ <foo> 42 77) #t))))))
80 (test-assert "define-record-type* & inherit & let* behavior"
82 (define-record-type* <foo> foo make-foo
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))
93 (test-assert "define-record-type* & thunked"
95 (define-record-type* <foo> foo make-foo
98 (baz foo-baz (thunked)))
102 (baz (begin (set! calls (1+ calls)) 3)))))
104 (equal? (foo-bar x) 2)
105 (equal? (foo-baz x) 3) (= 1 calls)
106 (equal? (foo-baz x) 3) (= 2 calls)))))
108 (test-assert "define-record-type* & thunked & default"
110 (define-record-type* <foo> foo make-foo
113 (baz foo-baz (thunked) (default 42)))
115 (let ((mark (make-parameter #f)))
116 (let ((x (foo (bar 2) (baz (mark))))
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))))))
124 (test-assert "define-record-type* & thunked & inherited"
126 (define-record-type* <foo> foo make-foo
128 (bar foo-bar (thunked))
129 (baz foo-baz (thunked) (default 42)))
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))))))))
142 (test-assert "define-record-type* & delayed"
144 (define-record-type* <foo> foo make-foo
146 (bar foo-bar (delayed)))
149 (x (foo (bar (begin (set! calls (1+ calls)) 3)))))
151 (equal? (foo-bar x) 3) (= 1 calls)
152 (equal? (foo-bar x) 3) (= 1 calls)
153 (equal? (foo-bar x) 3) (= 1 calls)))))
155 (test-assert "define-record-type* & delayed & default"
157 (define-record-type* <foo> foo make-foo
159 (bar foo-bar (delayed) (default mark)))
163 (and (equal? (foo-bar x) 42)
166 (equal? (foo-bar x) 42))))))
168 (test-assert "define-record-type* & delayed & inherited"
170 (define-record-type* <foo> foo make-foo
172 (bar foo-bar (delayed))
173 (baz foo-baz (delayed)))
177 (x (foo (bar m) (baz n)))
178 (y (foo (inherit x) (baz 'b))))
180 (and (equal? (foo-bar x) 1)
184 (equal? (foo-bar y) 1)) ;promise was already forced
185 (eq? (foo-baz y) 'b)))))
187 (test-assert "define-record-type* & missing initializers"
191 (define-record-type* <foo> foo make-foo
193 (bar foo-bar (default 42))
199 (lambda (key proc message location form . args)
201 (string-match "missing .*initialize.*baz" message)
202 (equal? form '(foo))))))
204 (test-assert "define-record-type* & extra initializers"
208 (define-record-type* <foo> foo make-foo
210 (bar foo-bar (default 42)))
215 (lambda (key proc message location form . args)
216 (and (string-match "extra.*initializer.*baz" message)
219 (test-assert "define-record-type* & inherit & extra initializers"
223 (define-record-type* <foo> foo make-foo
225 (bar foo-bar (default 42)))
227 (foo (inherit (foo)) (baz 'what?)))
230 (lambda (key proc message location form . args)
231 (and (string-match "extra.*initializer.*baz" message)
234 (test-equal "recutils->alist"
237 ("Synopsis" . "foo bar")
238 ("Something_else" . "chbouib"))
240 ("Version" . "1.5")))
241 (let ((p (open-input-string "
242 # Comment following an empty line, and
243 # preceding a couple of empty lines, all of
244 # which should be silently consumed.
249 # Comment right in the middle,
250 # spanning two lines.
252 Something_else: chbouib
254 # Comment right before.
257 # Comment at the end.")))
258 (list (recutils->alist p)
259 (recutils->alist p))))
261 (test-equal "recutils->alist with + lines"
263 ("Description" . "1st line,\n2nd line,\n 3rd line with extra space,\n4th line without space."))
264 (recutils->alist (open-input-string "
266 Description: 1st line,
268 + 3rd line with extra space,
269 +4th line without space.")))
271 (test-equal "alist->record" '((1 2) b c)
272 (alist->record '(("a" . 1) ("b" . b) ("c" . c) ("a" . 2))
280 (exit (= (test-runner-fail-count (test-runner-current)) 0))