619 lines
19 KiB
Scheme
619 lines
19 KiB
Scheme
;;; GNU Guix --- Functional package management for GNU
|
||
;;; Copyright © 2012-2016, 2018-2022 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-1)
|
||
#:use-module (srfi srfi-64)
|
||
#:use-module (ice-9 match)
|
||
#:use-module (ice-9 regex)
|
||
#:use-module (guix records))
|
||
|
||
(define (test-module)
|
||
;; A module in which to evaluate things that are known to fail.
|
||
(let ((module (make-fresh-user-module)))
|
||
(module-use! module (resolve-interface '(guix records)))
|
||
module))
|
||
|
||
(define (location-alist loc)
|
||
;; Return a location alist. In Guile < 3.0.6, LOC is always an alist, but
|
||
;; starting with 3.0.6, LOC is a vector (at least when it comes from
|
||
;; 'syntax-error' exceptions), hence this conversion.
|
||
(match loc
|
||
(#(file line column)
|
||
`((line . ,line) (column . ,column)
|
||
(filename . ,file)))
|
||
(_ loc)))
|
||
|
||
|
||
(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 let* behavior"
|
||
;; Make sure field initializers can refer to each other as if they were in
|
||
;; a 'let*'.
|
||
(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) #t))
|
||
(match (bar (z 21) (x (/ z 3)))
|
||
(($ <bar> 7 42 21) #t)))))
|
||
|
||
(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 & let* 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* & inherit & innate"
|
||
(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (innate) (default 42)))
|
||
(let* ((a (foo (bar 1)))
|
||
(b (foo (inherit a)))
|
||
(c (foo (inherit a) (bar 3)))
|
||
(d (foo)))
|
||
(and (match a (($ <foo> 1) #t))
|
||
(match b (($ <foo> 42) #t))
|
||
(match c (($ <foo> 3) #t))
|
||
(match d (($ <foo> 42) #t))))))
|
||
|
||
(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-assert "define-record-type* & thunked & innate"
|
||
(let ((mark (make-parameter #f)))
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (thunked) (innate) (default (mark)))
|
||
(baz foo-baz (default #f)))
|
||
|
||
(let* ((x (foo (bar 42)))
|
||
(y (foo (inherit x) (baz 'unused))))
|
||
(and (procedure? (struct-ref x 0))
|
||
(equal? (foo-bar x) 42)
|
||
(parameterize ((mark (cons 'a 'b)))
|
||
(eq? (foo-bar y) (mark)))
|
||
(parameterize ((mark (cons 'a 'b)))
|
||
(eq? (foo-bar y) (mark)))))))
|
||
|
||
(test-assert "define-record-type* & thunked & this-record"
|
||
(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar)
|
||
(baz foo-baz (thunked)))
|
||
|
||
(let ((x (foo (bar 40)
|
||
(baz (+ (foo-bar this-record) 2)))))
|
||
(and (= 40 (foo-bar x))
|
||
(= 42 (foo-baz x))))))
|
||
|
||
(test-assert "define-record-type* & thunked & default & this-record"
|
||
(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar)
|
||
(baz foo-baz (thunked)
|
||
(default (+ (foo-bar this-record) 2))))
|
||
|
||
(let ((x (foo (bar 40))))
|
||
(and (= 40 (foo-bar x))
|
||
(= 42 (foo-baz x))))))
|
||
|
||
(test-assert "define-record-type* & thunked & inherit & this-record"
|
||
(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar)
|
||
(baz foo-baz (thunked)
|
||
(default (+ (foo-bar this-record) 2))))
|
||
|
||
(let* ((x (foo (bar 40)))
|
||
(y (foo (inherit x) (bar -2)))
|
||
(z (foo (inherit x) (baz -2))))
|
||
(and (= -2 (foo-bar y))
|
||
(= 0 (foo-baz y))
|
||
(= 40 (foo-bar z))
|
||
(= -2 (foo-baz z))))))
|
||
|
||
(test-assert "define-record-type* & thunked & inherit & custom this"
|
||
(let ()
|
||
(define-record-type* <foo> foo make-foo
|
||
foo? this-foo
|
||
(thing foo-thing (thunked)))
|
||
(define-record-type* <bar> bar make-bar
|
||
bar? this-bar
|
||
(baz bar-baz (thunked)))
|
||
|
||
;; Nest records and test the two self references.
|
||
(let* ((x (foo (thing (bar (baz (list this-bar this-foo))))))
|
||
(y (foo-thing x)))
|
||
(match (bar-baz y)
|
||
((first second)
|
||
(and (eq? second x)
|
||
(bar? first)
|
||
(eq? first y)))))))
|
||
|
||
(test-assert "define-record-type* & delayed"
|
||
(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (delayed)))
|
||
|
||
(let* ((calls 0)
|
||
(x (foo (bar (begin (set! calls (1+ calls)) 3)))))
|
||
(and (zero? calls)
|
||
(equal? (foo-bar x) 3) (= 1 calls)
|
||
(equal? (foo-bar x) 3) (= 1 calls)
|
||
(equal? (foo-bar x) 3) (= 1 calls)))))
|
||
|
||
(test-assert "define-record-type* & delayed & default"
|
||
(let ((mark #f))
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (delayed) (default mark)))
|
||
|
||
(let ((x (foo)))
|
||
(set! mark 42)
|
||
(and (equal? (foo-bar x) 42)
|
||
(begin
|
||
(set! mark 7)
|
||
(equal? (foo-bar x) 42))))))
|
||
|
||
(test-assert "define-record-type* & delayed & inherited"
|
||
(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (delayed))
|
||
(baz foo-baz (delayed)))
|
||
|
||
(let* ((m 1)
|
||
(n #f)
|
||
(x (foo (bar m) (baz n)))
|
||
(y (foo (inherit x) (baz 'b))))
|
||
(set! n 'a)
|
||
(and (equal? (foo-bar x) 1)
|
||
(eq? (foo-baz x) 'a)
|
||
(begin
|
||
(set! m 777)
|
||
(equal? (foo-bar y) 1)) ;promise was already forced
|
||
(eq? (foo-baz y) 'b)))))
|
||
|
||
(test-assert "define-record-type* & sanitize"
|
||
(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar
|
||
(default "bar")
|
||
(sanitize (lambda (x) (string-append x "!")))))
|
||
|
||
(let* ((p (foo))
|
||
(q (foo (inherit p)))
|
||
(r (foo (inherit p) (bar "baz")))
|
||
(s (foo (bar "baz"))))
|
||
(and (string=? (foo-bar p) "bar!")
|
||
(equal? q p)
|
||
(string=? (foo-bar r) "baz!")
|
||
(equal? s r)))))
|
||
|
||
(test-equal "define-record-type* & sanitize without default value"
|
||
42
|
||
(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (sanitize 1+)))
|
||
|
||
(foo-bar (foo (bar 41)))))
|
||
|
||
(test-assert "define-record-type* & sanitize & thunked"
|
||
(let ((sanitized 0))
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar
|
||
(default "bar")
|
||
(sanitize (lambda (x)
|
||
(set! sanitized (+ 1 sanitized))
|
||
(string-append x "!")))))
|
||
|
||
(let ((p (foo)))
|
||
(and (string=? (foo-bar p) "bar!")
|
||
(string=? (foo-bar p) "bar!") ;twice
|
||
(= sanitized 1) ;sanitizer was called at init time only
|
||
(let ((q (foo (bar "baz"))))
|
||
(and (string=? (foo-bar q) "baz!")
|
||
(string=? (foo-bar q) "baz!") ;twice
|
||
(= sanitized 2)
|
||
(let ((r (foo (inherit q))))
|
||
(and (string=? (foo-bar r) "baz!")
|
||
(= sanitized 2))))))))) ;no re-sanitization
|
||
|
||
(test-assert "define-record-type* & wrong field specifier"
|
||
(let ((exp '(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (default 42))
|
||
(baz foo-baz))
|
||
|
||
(foo (baz 1 2 3 4 5)))) ;syntax error
|
||
(loc (current-source-location))) ;keep this alignment!
|
||
(catch 'syntax-error
|
||
(lambda ()
|
||
(eval exp (test-module))
|
||
#f)
|
||
(lambda (key proc message location form subform . _)
|
||
(and (eq? proc 'foo)
|
||
(string-match "invalid field" message)
|
||
(equal? subform '(baz 1 2 3 4 5))
|
||
(equal? form '(foo (baz 1 2 3 4 5)))
|
||
|
||
;; Make sure the location is that of the field specifier.
|
||
;; See <http://bugs.gnu.org/23969>.
|
||
(lset= equal?
|
||
(pk 'expected-loc
|
||
`((line . ,(- (assq-ref loc 'line) 1))
|
||
,@(alist-delete 'line loc)))
|
||
(pk 'actual-loc (location-alist location))))))))
|
||
|
||
(test-assert "define-record-type* & wrong field specifier, identifier"
|
||
(let ((exp '(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (default 42))
|
||
(baz foo-baz))
|
||
|
||
(foo
|
||
baz))) ;syntax error
|
||
(loc (current-source-location))) ;keep this alignment!
|
||
(catch 'syntax-error
|
||
(lambda ()
|
||
(eval exp (test-module))
|
||
#f)
|
||
(lambda (key proc message location form subform . _)
|
||
(and (eq? proc 'foo)
|
||
(string-match "invalid field" message)
|
||
(equal? subform 'baz)
|
||
(equal? form '(foo baz))
|
||
|
||
;; Here the location is that of the parent form.
|
||
(lset= equal?
|
||
(pk 'expected-loc
|
||
`((line . ,(- (assq-ref loc 'line) 2))
|
||
,@(alist-delete 'line loc)))
|
||
(pk 'actual-loc (location-alist location))))))))
|
||
|
||
(test-assert "define-record-type* & missing initializers"
|
||
(catch 'syntax-error
|
||
(lambda ()
|
||
(eval '(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (default 42))
|
||
(baz foo-baz))
|
||
|
||
(foo))
|
||
(test-module))
|
||
#f)
|
||
(lambda (key proc message location form . args)
|
||
(and (eq? proc 'foo)
|
||
(string-match "missing .*initialize.*baz" message)
|
||
(equal? form '(foo))))))
|
||
|
||
(test-assert "define-record-type* & extra initializers"
|
||
(catch 'syntax-error
|
||
(lambda ()
|
||
(eval '(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (default 42)))
|
||
|
||
(foo (baz 'what?)))
|
||
(test-module))
|
||
#f)
|
||
(lambda (key proc message location form . args)
|
||
(and (string-match "extra.*initializer.*baz" message)
|
||
(eq? proc 'foo)))))
|
||
|
||
(test-assert "define-record-type* & inherit & extra initializers"
|
||
(catch 'syntax-error
|
||
(lambda ()
|
||
(eval '(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (default 42)))
|
||
|
||
(foo (inherit (foo)) (baz 'what?)))
|
||
(test-module))
|
||
#f)
|
||
(lambda (key proc message location form . args)
|
||
(and (string-match "extra.*initializer.*baz" message)
|
||
(eq? proc 'foo)))))
|
||
|
||
(test-assert "define-record-type* & duplicate initializers"
|
||
(let ((exp '(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (default 42)))
|
||
|
||
(foo (bar 1)
|
||
(bar 2))))
|
||
(loc (current-source-location))) ;keep this alignment!
|
||
(catch 'syntax-error
|
||
(lambda ()
|
||
(eval exp (test-module))
|
||
#f)
|
||
(lambda (key proc message location form . args)
|
||
(and (string-match "duplicate.*initializer" message)
|
||
(eq? proc 'foo)
|
||
|
||
;; Make sure the location is that of the field specifier.
|
||
(lset= equal?
|
||
(pk 'expected-loc
|
||
`((line . ,(- (assq-ref loc 'line) 1))
|
||
,@(alist-delete 'line loc)))
|
||
(pk 'actual-loc (location-alist location))))))))
|
||
|
||
(test-assert "ABI checks"
|
||
(let ((module (test-module)))
|
||
(eval '(begin
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(bar foo-bar (default 42)))
|
||
|
||
(define (make-me-a-record) (foo)))
|
||
module)
|
||
(unless (eval '(foo? (make-me-a-record)) module)
|
||
(error "what?" (eval '(make-me-a-record) module)))
|
||
|
||
;; Redefine <foo> with an additional field.
|
||
(eval '(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(baz foo-baz)
|
||
(bar foo-bar (default 42)))
|
||
module)
|
||
|
||
;; Now 'make-me-a-record' is out of sync because it does an
|
||
;; 'allocate-struct' that corresponds to the previous definition of <foo>.
|
||
(catch 'record-abi-mismatch-error
|
||
(lambda ()
|
||
(eval '(foo? (make-me-a-record)) module)
|
||
#f)
|
||
(match-lambda*
|
||
((key 'abi-check (? string? message) (rtd) . _)
|
||
(eq? rtd (eval '<foo> module)))))))
|
||
|
||
(test-equal "recutils->alist"
|
||
'((("Name" . "foo")
|
||
("Version" . "0.1")
|
||
("Synopsis" . "foo bar")
|
||
("Something_else" . "chbouib"))
|
||
(("Name" . "bar")
|
||
("Version" . "1.5")))
|
||
(let ((p (open-input-string "
|
||
# Comment following an empty line, and
|
||
# preceding a couple of empty lines, all of
|
||
# which should be silently consumed.
|
||
|
||
|
||
Name: foo
|
||
Version: 0.1
|
||
# Comment right in the middle,
|
||
# spanning two lines.
|
||
Synopsis: foo bar
|
||
Something_else: chbouib
|
||
|
||
# Comment right before.
|
||
Name: bar
|
||
Version: 1.5
|
||
# Comment at the end.")))
|
||
(list (recutils->alist p)
|
||
(recutils->alist p))))
|
||
|
||
(test-equal "recutils->alist with + lines"
|
||
'(("Name" . "foo")
|
||
("Description" . "1st line,\n2nd line,\n 3rd line with extra space,\n4th line without space."))
|
||
(recutils->alist (open-input-string "
|
||
Name: foo
|
||
Description: 1st line,
|
||
+ 2nd line,
|
||
+ 3rd line with extra space,
|
||
+4th line without space.")))
|
||
|
||
(test-equal "alist->record" '((1 2) b c)
|
||
(alist->record '(("a" . 1) ("b" . b) ("c" . c) ("a" . 2))
|
||
list
|
||
'("a" "b" "c")
|
||
'("a")))
|
||
|
||
(test-equal "match-record, simple"
|
||
'((1 2) (a b))
|
||
(let ()
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(first foo-first (default 1))
|
||
(second foo-second))
|
||
|
||
(list (match-record (foo (second 2)) <foo>
|
||
(first second)
|
||
(list first second))
|
||
(match-record (foo (first 'a) (second 'b)) <foo>
|
||
(second (first first/new-var))
|
||
(list first/new-var second)))))
|
||
|
||
(test-equal "match-record, unknown field"
|
||
'syntax-error
|
||
(catch 'syntax-error
|
||
(lambda ()
|
||
(eval '(begin
|
||
(use-modules (guix records))
|
||
|
||
(define-record-type* <foo> foo make-foo
|
||
foo?
|
||
(first foo-first (default 1))
|
||
(second foo-second))
|
||
|
||
(match-record (foo (second 2)) <foo>
|
||
(one two)
|
||
#f))
|
||
(make-fresh-user-module)))
|
||
(lambda (key . args) key)))
|
||
|
||
(test-equal "match-record, delayed field"
|
||
"foo bar bar foo"
|
||
(begin
|
||
(define-record-type* <with-delayed> with-delayed make-with-delayed
|
||
with-delayed?
|
||
(delayed with-delayed-delayed
|
||
(delayed)))
|
||
|
||
(let ((rec (with-delayed
|
||
(delayed "foo bar bar foo"))))
|
||
(match-record rec <with-delayed> (delayed)
|
||
delayed))))
|
||
|
||
(test-equal "match-record, thunked field"
|
||
'("foo" "foobar")
|
||
(begin
|
||
(define-record-type* <with-thunked> with-thunked make-with-thunked
|
||
with-thunked?
|
||
(normal with-thunked-normal)
|
||
(thunked with-thunked-thunked
|
||
(thunked)))
|
||
|
||
(let ((rec (with-thunked
|
||
(normal "foo")
|
||
(thunked (string-append (with-thunked-normal this-record)
|
||
"bar")))))
|
||
(match-record rec <with-thunked> (normal thunked)
|
||
(list normal thunked)))))
|
||
|
||
(test-equal "match-record, ellipsis in body"
|
||
#t
|
||
(begin
|
||
(define-record-type* <foo> foo make-foo foo?
|
||
(value foo-value))
|
||
(define bar (foo (value '(1 2 3))))
|
||
(match-record bar <foo> (value)
|
||
(match value
|
||
((one two ...)
|
||
#t)
|
||
(_
|
||
#f)))))
|
||
|
||
(test-equal "match-record-lambda"
|
||
'("thing: foo" "thing: bar")
|
||
(begin
|
||
(define-record-type* <with-text> with-text make-with-text
|
||
with-text?
|
||
(text with-text-text))
|
||
|
||
(map (match-record-lambda <with-text> (text)
|
||
(string-append "thing: " text))
|
||
(list (with-text (text "foo"))
|
||
(with-text (text "bar"))))))
|
||
|
||
(test-end)
|