[jackhill/guix/guix.git] / tests / records.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015 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 (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))

\f
(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* & 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* & 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-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-end)
Commit	Line	Data
c0cd1b3e	1	;;; GNU Guix --- Functional package management for GNU
310b32a2	2	;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
c0cd1b3e LC	3	;;;
	4	;;; This file is part of GNU Guix.
	5	;;;
	6	;;; GNU Guix is free software; you can redistribute it and/or modify it
	7	;;; under the terms of the GNU General Public License as published by
	8	;;; the Free Software Foundation; either version 3 of the License, or (at
	9	;;; your option) any later version.
	10	;;;
	11	;;; GNU Guix is distributed in the hope that it will be useful, but
	12	;;; WITHOUT ANY WARRANTY; without even the implied warranty of
	13	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	14	;;; GNU General Public License for more details.
	15	;;;
	16	;;; You should have received a copy of the GNU General Public License
	17	;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
	18
	19	(define-module (test-records)
	20	#:use-module (srfi srfi-64)
	21	#:use-module (ice-9 match)
23e9a680	22	#:use-module (ice-9 regex)
c0cd1b3e LC	23	#:use-module (guix records))
c0cd1b3e LC	24
23e9a680 LC	25	(define (test-module)
	26	;; A module in which to evaluate things that are known to fail.
	27	(let ((module (make-fresh-user-module)))
	28	(module-use! module (resolve-interface '(guix records)))
	29	module))
	30
	31	\f
c0cd1b3e LC	32	(test-begin "records")
	33
	34	(test-assert "define-record-type*"
	35	(begin
	36	(define-record-type* <foo> foo make-foo
	37	foo?
	38	(bar foo-bar)
	39	(baz foo-baz (default (+ 40 2))))
	40	(and (match (foo (bar 1) (baz 2))
	41	(($ <foo> 1 2) #t))
	42	(match (foo (baz 2) (bar 1))
	43	(($ <foo> 1 2) #t))
	44	(match (foo (bar 1))
	45	(($ <foo> 1 42) #t)))))
	46
59fbeb8c	47	(test-assert "define-record-type* with let* behavior"
c0cd1b3e	48	;; Make sure field initializers can refer to each other as if they were in
59fbeb8c	49	;; a 'let*'.
c0cd1b3e LC	50	(begin
	51	(define-record-type* <bar> bar make-bar
	52	foo?
	53	(x bar-x)
	54	(y bar-y (default (+ 40 2)))
	55	(z bar-z))
	56	(and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
	57	(($ <bar> 1 2 4) #t))
	58	(match (bar (x 7) (z (* x 3)))
6c356414	59	(($ <bar> 7 42 21) #t))
c0cd1b3e	60	(match (bar (z 21) (x (/ z 3)))
a1906758	61	(($ <bar> 7 42 21) #t)))))
c0cd1b3e LC	62
	63	(test-assert "define-record-type* & inherit"
	64	(begin
	65	(define-record-type* <foo> foo make-foo
	66	foo?
	67	(bar foo-bar)
	68	(baz foo-baz (default (+ 40 2))))
	69	(let* ((a (foo (bar 1)))
	70	(b (foo (inherit a) (baz 2)))
	71	(c (foo (inherit b) (bar -2)))
	72	(d (foo (inherit c)))
	73	(e (foo (inherit (foo (bar 42))) (baz 77))))
	74	(and (match a (($ <foo> 1 42) #t))
	75	(match b (($ <foo> 1 2) #t))
	76	(match c (($ <foo> -2 2) #t))
	77	(equal? c d)
	78	(match e (($ <foo> 42 77) #t))))))
	79
59fbeb8c	80	(test-assert "define-record-type* & inherit & let* behavior"
c0cd1b3e LC	81	(begin
	82	(define-record-type* <foo> foo make-foo
	83	foo?
	84	(bar foo-bar)
	85	(baz foo-baz (default (+ 40 2))))
	86	(let* ((a (foo (bar 77)))
	87	(b (foo (inherit a) (bar 1) (baz (+ bar 1))))
	88	(c (foo (inherit b) (baz 2) (bar (- baz 1)))))
	89	(and (match a (($ <foo> 77 42) #t))
	90	(match b (($ <foo> 1 2) #t))
	91	(equal? b c)))))
	92
8a16d064 LC	93	(test-assert "define-record-type* & inherit & innate"
	94	(begin
	95	(define-record-type* <foo> foo make-foo
	96	foo?
	97	(bar foo-bar (innate) (default 42)))
	98	(let* ((a (foo (bar 1)))
	99	(b (foo (inherit a)))
	100	(c (foo (inherit a) (bar 3)))
	101	(d (foo)))
	102	(and (match a (($ <foo> 1) #t))
	103	(match b (($ <foo> 42) #t))
	104	(match c (($ <foo> 3) #t))
	105	(match d (($ <foo> 42) #t))))))
	106
c0cd1b3e LC	107	(test-assert "define-record-type* & thunked"
	108	(begin
	109	(define-record-type* <foo> foo make-foo
	110	foo?
	111	(bar foo-bar)
	112	(baz foo-baz (thunked)))
	113
	114	(let* ((calls 0)
	115	(x (foo (bar 2)
	116	(baz (begin (set! calls (1+ calls)) 3)))))
	117	(and (zero? calls)
	118	(equal? (foo-bar x) 2)
	119	(equal? (foo-baz x) 3) (= 1 calls)
	120	(equal? (foo-baz x) 3) (= 2 calls)))))
	121
	122	(test-assert "define-record-type* & thunked & default"
	123	(begin
	124	(define-record-type* <foo> foo make-foo
	125	foo?
	126	(bar foo-bar)
	127	(baz foo-baz (thunked) (default 42)))
	128
	129	(let ((mark (make-parameter #f)))
	130	(let ((x (foo (bar 2) (baz (mark))))
	131	(y (foo (bar 2))))
	132	(and (equal? (foo-bar x) 2)
	133	(parameterize ((mark (cons 'a 'b)))
	134	(eq? (foo-baz x) (mark)))
	135	(equal? (foo-bar y) 2)
	136	(equal? (foo-baz y) 42))))))
	137
	138	(test-assert "define-record-type* & thunked & inherited"
	139	(begin
	140	(define-record-type* <foo> foo make-foo
	141	foo?
	142	(bar foo-bar (thunked))
	143	(baz foo-baz (thunked) (default 42)))
	144
	145	(let ((mark (make-parameter #f)))
	146	(let* ((x (foo (bar 2) (baz (mark))))
	147	(y (foo (inherit x) (bar (mark)))))
	148	(and (equal? (foo-bar x) 2)
	149	(parameterize ((mark (cons 'a 'b)))
	150	(eq? (foo-baz x) (mark)))
	151	(parameterize ((mark (cons 'a 'b)))
	152	(eq? (foo-bar y) (mark)))
	153	(parameterize ((mark (cons 'a 'b)))
	154	(eq? (foo-baz y) (mark))))))))
	155
8a16d064 LC	156	(test-assert "define-record-type* & thunked & innate"
	157	(let ((mark (make-parameter #f)))
	158	(define-record-type* <foo> foo make-foo
	159	foo?
	160	(bar foo-bar (thunked) (innate) (default (mark)))
	161	(baz foo-baz (default #f)))
	162
	163	(let* ((x (foo (bar 42)))
	164	(y (foo (inherit x) (baz 'unused))))
	165	(and (procedure? (struct-ref x 0))
	166	(equal? (foo-bar x) 42)
	167	(parameterize ((mark (cons 'a 'b)))
	168	(eq? (foo-bar y) (mark)))
	169	(parameterize ((mark (cons 'a 'b)))
	170	(eq? (foo-bar y) (mark)))))))
	171
310b32a2 LC	172	(test-assert "define-record-type* & delayed"
	173	(begin
	174	(define-record-type* <foo> foo make-foo
	175	foo?
	176	(bar foo-bar (delayed)))
	177
	178	(let* ((calls 0)
	179	(x (foo (bar (begin (set! calls (1+ calls)) 3)))))
	180	(and (zero? calls)
	181	(equal? (foo-bar x) 3) (= 1 calls)
	182	(equal? (foo-bar x) 3) (= 1 calls)
	183	(equal? (foo-bar x) 3) (= 1 calls)))))
	184
	185	(test-assert "define-record-type* & delayed & default"
	186	(let ((mark #f))
	187	(define-record-type* <foo> foo make-foo
	188	foo?
	189	(bar foo-bar (delayed) (default mark)))
	190
	191	(let ((x (foo)))
	192	(set! mark 42)
	193	(and (equal? (foo-bar x) 42)
	194	(begin
	195	(set! mark 7)
	196	(equal? (foo-bar x) 42))))))
	197
	198	(test-assert "define-record-type* & delayed & inherited"
	199	(begin
	200	(define-record-type* <foo> foo make-foo
	201	foo?
	202	(bar foo-bar (delayed))
	203	(baz foo-baz (delayed)))
	204
	205	(let* ((m 1)
	206	(n #f)
	207	(x (foo (bar m) (baz n)))
	208	(y (foo (inherit x) (baz 'b))))
	209	(set! n 'a)
	210	(and (equal? (foo-bar x) 1)
	211	(eq? (foo-baz x) 'a)
	212	(begin
	213	(set! m 777)
	214	(equal? (foo-bar y) 1)) ;promise was already forced
	215	(eq? (foo-baz y) 'b)))))
	216
23e9a680 LC	217	(test-assert "define-record-type* & missing initializers"
	218	(catch 'syntax-error
	219	(lambda ()
	220	(eval '(begin
	221	(define-record-type* <foo> foo make-foo
	222	foo?
	223	(bar foo-bar (default 42))
	224	(baz foo-baz))
	225
	226	(foo))
	227	(test-module))
	228	#f)
	229	(lambda (key proc message location form . args)
	230	(and (eq? proc 'foo)
	231	(string-match "missing .initialize.baz" message)
	232	(equal? form '(foo))))))
	233
	234	(test-assert "define-record-type* & extra initializers"
	235	(catch 'syntax-error
	236	(lambda ()
	237	(eval '(begin
	238	(define-record-type* <foo> foo make-foo
	239	foo?
	240	(bar foo-bar (default 42)))
	241
	242	(foo (baz 'what?)))
	243	(test-module))
	244	#f)
	245	(lambda (key proc message location form . args)
	246	(and (string-match "extra.initializer.baz" message)
	247	(eq? proc 'foo)))))
	248
a1906758 LC	249	(test-assert "define-record-type* & inherit & extra initializers"
	250	(catch 'syntax-error
	251	(lambda ()
	252	(eval '(begin
	253	(define-record-type* <foo> foo make-foo
	254	foo?
	255	(bar foo-bar (default 42)))
	256
	257	(foo (inherit (foo)) (baz 'what?)))
	258	(test-module))
	259	#f)
	260	(lambda (key proc message location form . args)
	261	(and (string-match "extra.initializer.baz" message)
	262	(eq? proc 'foo)))))
	263
fdc1bf65 LC	264	(test-equal "recutils->alist"
	265	'((("Name" . "foo")
	266	("Version" . "0.1")
	267	("Synopsis" . "foo bar")
	268	("Something_else" . "chbouib"))
	269	(("Name" . "bar")
	270	("Version" . "1.5")))
b7b88288 LC	271	(let ((p (open-input-string "
	272	# Comment following an empty line, and
	273	# preceding a couple of empty lines, all of
	274	# which should be silently consumed.
	275
	276
	277	Name: foo
fdc1bf65	278	Version: 0.1
b7b88288 LC	279	# Comment right in the middle,
b7b88288 LC	280	# spanning two lines.
fdc1bf65 LC	281	Synopsis: foo bar
	282	Something_else: chbouib
	283
b7b88288	284	# Comment right before.
fdc1bf65	285	Name: bar
b7b88288 LC	286	Version: 1.5
b7b88288 LC	287	# Comment at the end.")))
fdc1bf65 LC	288	(list (recutils->alist p)
	289	(recutils->alist p))))
	290
836d10f1 LC	291	(test-equal "recutils->alist with + lines"
	292	'(("Name" . "foo")
	293	("Description" . "1st line,\n2nd line,\n 3rd line with extra space,\n4th line without space."))
	294	(recutils->alist (open-input-string "
	295	Name: foo
	296	Description: 1st line,
	297	+ 2nd line,
	298	+ 3rd line with extra space,
	299	+4th line without space.")))
	300
c8772a7a LC	301	(test-equal "alist->record" '((1 2) b c)
	302	(alist->record '(("a" . 1) ("b" . b) ("c" . c) ("a" . 2))
	303	list
	304	'("a" "b" "c")
	305	'("a")))
	306
c0cd1b3e	307	(test-end)