* 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.gn-latest-20200428
@@ -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 \ | |||
@@ -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 | |||
@@ -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 | |||
@@ -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) | |||
@@ -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 |
@@ -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." | |||
@@ -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))) | |||
@@ -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)) |
@@ -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" | |||