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.

Makefile.am

@@ -35,6 +35,7 @@ MODULES =					\
   guix/scripts/substitute-binary.scm		\
   guix/scripts/refresh.scm			\
   guix/base32.scm				\
+  guix/records.scm				\
   guix/utils.scm				\
   guix/serialization.scm			\
   guix/nar.scm					\
@@ -85,7 +86,7 @@ MODULES =					\
   gnu/packages/cpio.scm				\
   gnu/packages/cppi.scm				\
   gnu/packages/cross-base.scm			\
-  gnu/packages/cryptsetup.scm				\
+  gnu/packages/cryptsetup.scm			\
   gnu/packages/curl.scm				\
   gnu/packages/cyrus-sasl.scm			\
   gnu/packages/dejagnu.scm			\
@@ -121,11 +122,11 @@ MODULES =					\
   gnu/packages/icu4c.scm			\
   gnu/packages/idutils.scm			\
   gnu/packages/indent.scm			\
-  gnu/packages/irssi.scm 			\
+  gnu/packages/irssi.scm			\
   gnu/packages/ld-wrapper.scm			\
   gnu/packages/less.scm				\
   gnu/packages/lesstif.scm			\
-  gnu/packages/libapr.scm 			\
+  gnu/packages/libapr.scm			\
   gnu/packages/libdaemon.scm			\
   gnu/packages/libevent.scm			\
   gnu/packages/libffi.scm			\
@@ -156,7 +157,7 @@ MODULES =					\
   gnu/packages/ncurses.scm			\
   gnu/packages/netpbm.scm			\
   gnu/packages/nettle.scm			\
-  gnu/packages/ocaml.scm 			\
+  gnu/packages/ocaml.scm			\
   gnu/packages/oggvorbis.scm			\
   gnu/packages/openldap.scm			\
   gnu/packages/openssl.scm			\
@@ -176,22 +177,22 @@ MODULES =					\
   gnu/packages/rsync.scm			\
   gnu/packages/samba.scm			\
   gnu/packages/scheme.scm			\
-  gnu/packages/screen.scm 			\
+  gnu/packages/screen.scm			\
   gnu/packages/shishi.scm			\
   gnu/packages/smalltalk.scm			\
-  gnu/packages/sqlite.scm 			\
+  gnu/packages/sqlite.scm			\
   gnu/packages/ssh.scm				\
-  gnu/packages/subversion.scm 			\
+  gnu/packages/subversion.scm			\
   gnu/packages/system.scm			\
   gnu/packages/tcl.scm				\
-  gnu/packages/tcsh.scm 			\
+  gnu/packages/tcsh.scm				\
   gnu/packages/texinfo.scm			\
   gnu/packages/texlive.scm			\
   gnu/packages/time.scm				\
-  gnu/packages/tmux.scm 			\
+  gnu/packages/tmux.scm				\
   gnu/packages/tor.scm				\
   gnu/packages/version-control.scm		\
-  gnu/packages/vim.scm 				\
+  gnu/packages/vim.scm				\
   gnu/packages/vpn.scm				\
   gnu/packages/w3m.scm				\
   gnu/packages/wdiff.scm			\
@@ -313,6 +314,7 @@ SCM_TESTS =					\
   tests/builders.scm				\
   tests/derivations.scm				\
   tests/ui.scm					\
+  tests/records.scm				\
   tests/utils.scm				\
   tests/build-utils.scm				\
   tests/packages.scm				\

guix/build-system.scm

@@ -1,5 +1,5 @@
 ;;; GNU Guix --- Functional package management for GNU
-;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -17,7 +17,7 @@
 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
 
 (define-module (guix build-system)
-  #:use-module (guix utils)
+  #:use-module (guix records)
   #:export (build-system
             build-system?
             build-system-name

guix/gnu-maintenance.scm

@@ -32,6 +32,7 @@
   #:use-module (guix ftp-client)
   #:use-module (guix ui)
   #:use-module (guix utils)
+  #:use-module (guix records)
   #:use-module (guix packages)
   #:use-module ((guix download) #:select (download-to-store))
   #:use-module (guix gnupg)
@@ -150,12 +151,6 @@
           (remove null-list? state)
           (match-field line))))
 
-  (define (alist->record alist make keys)
-    ;; Apply MAKE, which should be a syntactic constructor, to the
-    ;; values associated with KEYS in ALIST.
-    (let ((args (map (cut assoc-ref alist <>) keys)))
-      (apply make args)))
-
   (reverse
    (map (lambda (alist)
           (alist->record alist

guix/packages.scm

@@ -18,6 +18,7 @@
 
 (define-module (guix packages)
   #:use-module (guix utils)
+  #:use-module (guix records)
   #:use-module (guix store)
   #:use-module (guix base32)
   #:use-module (guix derivations)

guix/records.scm

@@ -0,0 +1,214 @@
+;;; 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 (guix records)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:export (define-record-type*
+            alist->record
+            object->fields))
+
+;;; Commentary:
+;;;
+;;; Utilities for dealing with Scheme records.
+;;;
+;;; Code:
+
+(define-syntax define-record-type*
+  (lambda (s)
+    "Define the given record type such that an additional \"syntactic
+constructor\" is defined, which allows instances to be constructed with named
+field initializers, à la SRFI-35, as well as default values."
+    (define (make-syntactic-constructor type name ctor fields thunked defaults)
+      "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
+expects all of FIELDS to be initialized.  DEFAULTS is the list of
+FIELD/DEFAULT-VALUE tuples, and THUNKED is the list of identifiers of
+thunked fields."
+      (with-syntax ((type     type)
+                    (name     name)
+                    (ctor     ctor)
+                    (expected fields)
+                    (defaults defaults))
+        #`(define-syntax name
+            (lambda (s)
+              (define (record-inheritance orig-record field+value)
+                ;; Produce code that returns a record identical to
+                ;; ORIG-RECORD, except that values for the FIELD+VALUE alist
+                ;; prevail.
+                (define (field-inherited-value f)
+                  (and=> (find (lambda (x)
+                                 (eq? f (car (syntax->datum x))))
+                               field+value)
+                         car))
+
+                #`(make-struct type 0
+                               #,@(map (lambda (field index)
+                                         (or (field-inherited-value field)
+                                             #`(struct-ref #,orig-record
+                                                           #,index)))
+                                       'expected
+                                       (iota (length 'expected)))))
+
+              (define (thunked-field? f)
+                (memq (syntax->datum f) '#,thunked))
+
+              (define (field-bindings field+value)
+                ;; Return field to value bindings, for use in `letrec*' below.
+                (map (lambda (field+value)
+                       (syntax-case field+value ()
+                         ((field value)
+                          #`(field
+                             #,(if (thunked-field? #'field)
+                                   #'(lambda () value)
+                                   #'value)))))
+                     field+value))
+
+              (syntax-case s (inherit #,@fields)
+                ((_ (inherit orig-record) (field value) (... ...))
+                 #`(letrec* #,(field-bindings #'((field value) (... ...)))
+                     #,(record-inheritance #'orig-record
+                                           #'((field value) (... ...)))))
+                ((_ (field value) (... ...))
+                 (let ((fields (map syntax->datum #'(field (... ...))))
+                       (dflt   (map (match-lambda
+                                     ((f v)
+                                      (list (syntax->datum f) v)))
+                                    #'defaults)))
+
+                   (define (field-value f)
+                     (or (and=> (find (lambda (x)
+                                        (eq? f (car (syntax->datum x))))
+                                      #'((field value) (... ...)))
+                                car)
+                         (let ((value
+                                (car (assoc-ref dflt
+                                                (syntax->datum f)))))
+                           (if (thunked-field? f)
+                               #`(lambda () #,value)
+                               value))))
+
+                   (let-syntax ((error*
+                                 (syntax-rules ()
+                                   ((_ fmt args (... ...))
+                                    (syntax-violation 'name
+                                                      (format #f fmt args
+                                                              (... ...))
+                                                      s)))))
+                     (let ((fields (append fields (map car dflt))))
+                       (cond ((lset= eq? fields 'expected)
+                              #`(letrec* #,(field-bindings
+                                            #'((field value) (... ...)))
+                                  (ctor #,@(map field-value 'expected))))
+                             ((pair? (lset-difference eq? fields 'expected))
+                              (error* "extraneous field initializers ~a"
+                                      (lset-difference eq? fields 'expected)))
+                             (else
+                              (error* "missing field initializers ~a"
+                                      (lset-difference eq? 'expected
+                                                       fields)))))))))))))
+
+    (define (field-default-value s)
+      (syntax-case s (default)
+        ((field (default val) _ ...)
+         (list #'field #'val))
+        ((field _ options ...)
+         (field-default-value #'(field options ...)))
+        (_ #f)))
+
+    (define (thunked-field? s)
+      ;; Return the field name if the field defined by S is thunked.
+      (syntax-case s (thunked)
+        ((field (thunked) _ ...)
+         #'field)
+        ((field _ options ...)
+         (thunked-field? #'(field options ...)))
+        (_ #f)))
+
+    (define (thunked-field-accessor-name field)
+      ;; Return the name (an unhygienic syntax object) of the "real"
+      ;; getter for field, which is assumed to be a thunked field.
+      (syntax-case field ()
+        ((field get options ...)
+         (let* ((getter      (syntax->datum #'get))
+                (real-getter (symbol-append '% getter '-real)))
+           (datum->syntax #'get real-getter)))))
+
+    (define (field-spec->srfi-9 field)
+      ;; Convert a field spec of our style to a SRFI-9 field spec of the
+      ;; form (field get).
+      (syntax-case field ()
+        ((name get options ...)
+         #`(name
+            #,(if (thunked-field? field)
+                  (thunked-field-accessor-name field)
+                  #'get)))))
+
+    (define (thunked-field-accessor-definition field)
+      ;; Return the real accessor for FIELD, which is assumed to be a
+      ;; thunked field.
+      (syntax-case field ()
+        ((name get _ ...)
+         (with-syntax ((real-get (thunked-field-accessor-name field)))
+           #'(define-inlinable (get x)
+               ;; The real value of that field is a thunk, so call it.
+               ((real-get x)))))))
+
+    (syntax-case s ()
+      ((_ type syntactic-ctor ctor pred
+          (field get options ...) ...)
+       (let* ((field-spec #'((field get options ...) ...)))
+         (with-syntax (((field-spec* ...)
+                        (map field-spec->srfi-9 field-spec))
+                       ((thunked-field-accessor ...)
+                        (filter-map (lambda (field)
+                                      (and (thunked-field? field)
+                                           (thunked-field-accessor-definition
+                                            field)))
+                                    field-spec)))
+           #`(begin
+               (define-record-type type
+                 (ctor field ...)
+                 pred
+                 field-spec* ...)
+               (begin thunked-field-accessor ...)
+               #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
+                                             #'(field ...)
+                                             (filter-map thunked-field? field-spec)
+                                             (filter-map field-default-value
+                                                         #'((field options ...)
+                                                            ...))))))))))
+
+(define (alist->record alist make keys)
+  "Apply MAKE to the values associated with KEYS in ALIST."
+  (let ((args (map (cut assoc-ref alist <>) keys)))
+    (apply make args)))
+
+(define (object->fields object fields port)
+  "Write OBJECT (typically a record) as a series of recutils-style fields to
+PORT, according to FIELDS.  FIELDS must be a list of field name/getter pairs."
+  (let loop ((fields fields))
+    (match fields
+      (()
+       object)
+      (((field . get) rest ...)
+       (format port "~a: ~a~%" field (get object))
+       (loop rest)))))
+
+;;; records.scm ends here

guix/scripts/substitute-binary.scm

@@ -21,6 +21,7 @@
   #:use-module (guix store)
   #:use-module (guix utils)
   #:use-module (guix config)
+  #:use-module (guix records)
   #:use-module (guix nar)
   #:use-module ((guix build utils) #:select (mkdir-p))
   #:use-module (ice-9 rdelim)
@@ -103,22 +104,6 @@ pairs."
           (else
            (error "unmatched line" line)))))
 
-(define (alist->record alist make keys)
-  "Apply MAKE to the values associated with KEYS in ALIST."
-  (let ((args (map (cut assoc-ref alist <>) keys)))
-    (apply make args)))
-
-(define (object->fields object fields port)
-  "Write OBJECT (typically a record) as a series of recutils-style fields to
-PORT, according to FIELDS.  FIELDS must be a list of field name/getter pairs."
-  (let loop ((fields fields))
-    (match fields
-      (()
-       object)
-      (((field . get) rest ...)
-       (format port "~a: ~a~%" field (get object))
-       (loop rest)))))
-
 (define (fetch uri)
   "Return a binary input port to URI and the number of bytes it's expected to
 provide."

guix/utils.scm

@@ -42,7 +42,6 @@
             nixpkgs-derivation
             nixpkgs-derivation*
 
-            define-record-type*
             compile-time-value
             memoize
             default-keyword-arguments
@@ -239,170 +238,6 @@ wait."
 ;;; Miscellaneous.
 ;;;
 
-(define-syntax define-record-type*
-  (lambda (s)
-    "Define the given record type such that an additional \"syntactic
-constructor\" is defined, which allows instances to be constructed with named
-field initializers, à la SRFI-35, as well as default values."
-    (define (make-syntactic-constructor type name ctor fields thunked defaults)
-      "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
-expects all of FIELDS to be initialized.  DEFAULTS is the list of
-FIELD/DEFAULT-VALUE tuples, and THUNKED is the list of identifiers of
-thunked fields."
-      (with-syntax ((type     type)
-                    (name     name)
-                    (ctor     ctor)
-                    (expected fields)
-                    (defaults defaults))
-        #`(define-syntax name
-            (lambda (s)
-              (define (record-inheritance orig-record field+value)
-                ;; Produce code that returns a record identical to
-                ;; ORIG-RECORD, except that values for the FIELD+VALUE alist
-                ;; prevail.
-                (define (field-inherited-value f)
-                  (and=> (find (lambda (x)
-                                 (eq? f (car (syntax->datum x))))
-                               field+value)
-                         car))
-
-                #`(make-struct type 0
-                               #,@(map (lambda (field index)
-                                         (or (field-inherited-value field)
-                                             #`(struct-ref #,orig-record
-                                                           #,index)))
-                                       'expected
-                                       (iota (length 'expected)))))
-
-              (define (thunked-field? f)
-                (memq (syntax->datum f) '#,thunked))
-
-              (define (field-bindings field+value)
-                ;; Return field to value bindings, for use in `letrec*' below.
-                (map (lambda (field+value)
-                       (syntax-case field+value ()
-                         ((field value)
-                          #`(field
-                             #,(if (thunked-field? #'field)
-                                   #'(lambda () value)
-                                   #'value)))))
-                     field+value))
-
-              (syntax-case s (inherit #,@fields)
-                ((_ (inherit orig-record) (field value) (... ...))
-                 #`(letrec* #,(field-bindings #'((field value) (... ...)))
-                     #,(record-inheritance #'orig-record
-                                           #'((field value) (... ...)))))
-                ((_ (field value) (... ...))
-                 (let ((fields (map syntax->datum #'(field (... ...))))
-                       (dflt   (map (match-lambda
-                                     ((f v)
-                                      (list (syntax->datum f) v)))
-                                    #'defaults)))
-
-                   (define (field-value f)
-                     (or (and=> (find (lambda (x)
-                                        (eq? f (car (syntax->datum x))))
-                                      #'((field value) (... ...)))
-                                car)
-                         (let ((value
-                                (car (assoc-ref dflt
-                                                (syntax->datum f)))))
-                           (if (thunked-field? f)
-                               #`(lambda () #,value)
-                               value))))
-
-                   (let-syntax ((error*
-                                 (syntax-rules ()
-                                   ((_ fmt args (... ...))
-                                    (syntax-violation 'name
-                                                      (format #f fmt args
-                                                              (... ...))
-                                                      s)))))
-                     (let ((fields (append fields (map car dflt))))
-                       (cond ((lset= eq? fields 'expected)
-                              #`(letrec* #,(field-bindings
-                                            #'((field value) (... ...)))
-                                  (ctor #,@(map field-value 'expected))))
-                             ((pair? (lset-difference eq? fields 'expected))
-                              (error* "extraneous field initializers ~a"
-                                      (lset-difference eq? fields 'expected)))
-                             (else
-                              (error* "missing field initializers ~a"
-                                      (lset-difference eq? 'expected
-                                                       fields)))))))))))))
-
-    (define (field-default-value s)
-      (syntax-case s (default)
-        ((field (default val) _ ...)
-         (list #'field #'val))
-        ((field _ options ...)
-         (field-default-value #'(field options ...)))
-        (_ #f)))
-
-    (define (thunked-field? s)
-      ;; Return the field name if the field defined by S is thunked.
-      (syntax-case s (thunked)
-        ((field (thunked) _ ...)
-         #'field)
-        ((field _ options ...)
-         (thunked-field? #'(field options ...)))
-        (_ #f)))
-
-    (define (thunked-field-accessor-name field)
-      ;; Return the name (an unhygienic syntax object) of the "real"
-      ;; getter for field, which is assumed to be a thunked field.
-      (syntax-case field ()
-        ((field get options ...)
-         (let* ((getter      (syntax->datum #'get))
-                (real-getter (symbol-append '% getter '-real)))
-           (datum->syntax #'get real-getter)))))
-
-    (define (field-spec->srfi-9 field)
-      ;; Convert a field spec of our style to a SRFI-9 field spec of the
-      ;; form (field get).
-      (syntax-case field ()
-        ((name get options ...)
-         #`(name
-            #,(if (thunked-field? field)
-                  (thunked-field-accessor-name field)
-                  #'get)))))
-
-    (define (thunked-field-accessor-definition field)
-      ;; Return the real accessor for FIELD, which is assumed to be a
-      ;; thunked field.
-      (syntax-case field ()
-        ((name get _ ...)
-         (with-syntax ((real-get (thunked-field-accessor-name field)))
-           #'(define-inlinable (get x)
-               ;; The real value of that field is a thunk, so call it.
-               ((real-get x)))))))
-
-    (syntax-case s ()
-      ((_ type syntactic-ctor ctor pred
-          (field get options ...) ...)
-       (let* ((field-spec #'((field get options ...) ...)))
-         (with-syntax (((field-spec* ...)
-                        (map field-spec->srfi-9 field-spec))
-                       ((thunked-field-accessor ...)
-                        (filter-map (lambda (field)
-                                      (and (thunked-field? field)
-                                           (thunked-field-accessor-definition
-                                            field)))
-                                    field-spec)))
-           #`(begin
-               (define-record-type type
-                 (ctor field ...)
-                 pred
-                 field-spec* ...)
-               (begin thunked-field-accessor ...)
-               #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
-                                             #'(field ...)
-                                             (filter-map thunked-field? field-spec)
-                                             (filter-map field-default-value
-                                                         #'((field options ...)
-                                                            ...))))))))))
-
 (define (memoize proc)
   "Return a memoizing version of PROC."
   (let ((cache (make-hash-table)))

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))

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"