aboutsummaryrefslogtreecommitdiff
path: root/tests/records.scm
diff options
context:
space:
mode:
Diffstat (limited to 'tests/records.scm')
-rw-r--r--tests/records.scm137
1 files changed, 137 insertions, 0 deletions
diff --git a/tests/records.scm b/tests/records.scm
new file mode 100644
index 0000000000..9e524b670c
--- /dev/null
+++ b/tests/records.scm
@@ -0,0 +1,137 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix is distributed in the hope that it will be useful, but
+;;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-records)
+ #:use-module (srfi srfi-64)
+ #:use-module (ice-9 match)
+ #:use-module (guix records))
+
+(test-begin "records")
+
+(test-assert "define-record-type*"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (default (+ 40 2))))
+ (and (match (foo (bar 1) (baz 2))
+ (($ <foo> 1 2) #t))
+ (match (foo (baz 2) (bar 1))
+ (($ <foo> 1 2) #t))
+ (match (foo (bar 1))
+ (($ <foo> 1 42) #t)))))
+
+(test-assert "define-record-type* with letrec* behavior"
+ ;; Make sure field initializers can refer to each other as if they were in
+ ;; a `letrec*'.
+ (begin
+ (define-record-type* <bar> bar make-bar
+ foo?
+ (x bar-x)
+ (y bar-y (default (+ 40 2)))
+ (z bar-z))
+ (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
+ (($ <bar> 1 2 4) #t))
+ (match (bar (x 7) (z (* x 3)))
+ (($ <bar> 7 42 21)))
+ (match (bar (z 21) (x (/ z 3)))
+ (($ <bar> 7 42 21))))))
+
+(test-assert "define-record-type* & inherit"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (default (+ 40 2))))
+ (let* ((a (foo (bar 1)))
+ (b (foo (inherit a) (baz 2)))
+ (c (foo (inherit b) (bar -2)))
+ (d (foo (inherit c)))
+ (e (foo (inherit (foo (bar 42))) (baz 77))))
+ (and (match a (($ <foo> 1 42) #t))
+ (match b (($ <foo> 1 2) #t))
+ (match c (($ <foo> -2 2) #t))
+ (equal? c d)
+ (match e (($ <foo> 42 77) #t))))))
+
+(test-assert "define-record-type* & inherit & letrec* behavior"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (default (+ 40 2))))
+ (let* ((a (foo (bar 77)))
+ (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
+ (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
+ (and (match a (($ <foo> 77 42) #t))
+ (match b (($ <foo> 1 2) #t))
+ (equal? b c)))))
+
+(test-assert "define-record-type* & thunked"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (thunked)))
+
+ (let* ((calls 0)
+ (x (foo (bar 2)
+ (baz (begin (set! calls (1+ calls)) 3)))))
+ (and (zero? calls)
+ (equal? (foo-bar x) 2)
+ (equal? (foo-baz x) 3) (= 1 calls)
+ (equal? (foo-baz x) 3) (= 2 calls)))))
+
+(test-assert "define-record-type* & thunked & default"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (thunked) (default 42)))
+
+ (let ((mark (make-parameter #f)))
+ (let ((x (foo (bar 2) (baz (mark))))
+ (y (foo (bar 2))))
+ (and (equal? (foo-bar x) 2)
+ (parameterize ((mark (cons 'a 'b)))
+ (eq? (foo-baz x) (mark)))
+ (equal? (foo-bar y) 2)
+ (equal? (foo-baz y) 42))))))
+
+(test-assert "define-record-type* & thunked & inherited"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar (thunked))
+ (baz foo-baz (thunked) (default 42)))
+
+ (let ((mark (make-parameter #f)))
+ (let* ((x (foo (bar 2) (baz (mark))))
+ (y (foo (inherit x) (bar (mark)))))
+ (and (equal? (foo-bar x) 2)
+ (parameterize ((mark (cons 'a 'b)))
+ (eq? (foo-baz x) (mark)))
+ (parameterize ((mark (cons 'a 'b)))
+ (eq? (foo-bar y) (mark)))
+ (parameterize ((mark (cons 'a 'b)))
+ (eq? (foo-baz y) (mark))))))))
+
+(test-end)
+
+
+(exit (= (test-runner-fail-count (test-runner-current)) 0))