From c0cd1b3ea7753fe2826f7a336019000df9dea96f Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Sun, 12 May 2013 15:46:16 +0200
Subject: Move record utilities to (guix records).

* guix/utils.scm (define-record-type*): Move to...
* guix/records.scm: ... here.  New file.
* guix/build-system.scm, guix/packages.scm: Use it.
* guix/gnu-maintenance.scm: Likewise.
  (official-gnu-packages)[alist->record]: Remove.
* guix/scripts/substitute-binary.scm: Likewise.
  (alist->record, object->fields): Remove.
* tests/utils.scm ("define-record-type*", "define-record-type* with
  letrec* behavior", "define-record-type* & inherit",
  "define-record-type* & inherit & letrec* behavior",
  "define-record-type* & thunked", "define-record-type* & thunked &
  default", "define-record-type* & thunked & inherited"): Move to...
* tests/records.scm: ... here.  New file.
---
 tests/records.scm | 137 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 tests/utils.scm   | 108 ------------------------------------------
 2 files changed, 137 insertions(+), 108 deletions(-)
 create mode 100644 tests/records.scm

(limited to 'tests')

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"
-- 
cgit v1.2.3