diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/records.scm | 137 | ||||
| -rw-r--r-- | tests/utils.scm | 108 |
2 files changed, 137 insertions, 108 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)) diff --git a/tests/utils.scm b/tests/utils.scm index f14412e61e..c2fb274193 100644 --- a/tests/utils.scm +++ b/tests/utils.scm @@ -126,114 +126,6 @@ (append pids1 pids2))) (equal? (get-bytevector-all decompressed) data))))) -(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)))))))) - ;; This is actually in (guix store). (test-equal "store-path-package-name" "bash-4.2-p24" |