diff options
| -rw-r--r-- | Makefile.am | 22 | ||||
| -rw-r--r-- | guix/build-system.scm | 4 | ||||
| -rw-r--r-- | guix/gnu-maintenance.scm | 7 | ||||
| -rw-r--r-- | guix/packages.scm | 1 | ||||
| -rw-r--r-- | guix/records.scm | 214 | ||||
| -rwxr-xr-x | guix/scripts/substitute-binary.scm | 17 | ||||
| -rw-r--r-- | guix/utils.scm | 165 | ||||
| -rw-r--r-- | tests/records.scm | 137 | ||||
| -rw-r--r-- | tests/utils.scm | 108 |
9 files changed, 368 insertions, 307 deletions
diff --git a/Makefile.am b/Makefile.am index 3998e9123f..69b4af013a 100644 --- a/Makefile.am +++ b/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 \ diff --git a/guix/build-system.scm b/guix/build-system.scm index 0df5e4362b..c618a5e243 100644 --- a/guix/build-system.scm +++ b/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 diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm index e39094db72..b54cd84ecf 100644 --- a/guix/gnu-maintenance.scm +++ b/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 diff --git a/guix/packages.scm b/guix/packages.scm index 1cbbd2ec47..0549771cea 100644 --- a/guix/packages.scm +++ b/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) diff --git a/guix/records.scm b/guix/records.scm new file mode 100644 index 0000000000..54e1c17752 --- /dev/null +++ b/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 diff --git a/guix/scripts/substitute-binary.scm b/guix/scripts/substitute-binary.scm index 995078e630..5965e936f9 100755 --- a/guix/scripts/substitute-binary.scm +++ b/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." diff --git a/guix/utils.scm b/guix/utils.scm index 7c8e914c01..c2d2808f76 100644 --- a/guix/utils.scm +++ b/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))) 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" |