tests/records.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012-2016, 2018-2022 Ludovic Courtès <ludo@gnu.org>
   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-1)
  21   #:use-module (srfi srfi-64)
  22   #:use-module (ice-9 match)
  23   #:use-module (ice-9 regex)
  24   #:use-module (guix records))
  25
  26 (define (test-module)
  27   ;; A module in which to evaluate things that are known to fail.
  28   (let ((module (make-fresh-user-module)))
  29     (module-use! module (resolve-interface '(guix records)))
  30     module))
  31
  32 (define (location-alist loc)
  33   ;; Return a location alist.  In Guile < 3.0.6, LOC is always an alist, but
  34   ;; starting with 3.0.6, LOC is a vector (at least when it comes from
  35   ;; 'syntax-error' exceptions), hence this conversion.
  36   (match loc
  37     (#(file line column)
  38      `((line . ,line) (column . ,column)
  39        (filename . ,file)))
  40     (_ loc)))
  41
  42 \f
  43 (test-begin "records")
  44
  45 (test-assert "define-record-type*"
  46   (begin
  47     (define-record-type* <foo> foo make-foo
  48       foo?
  49       (bar foo-bar)
  50       (baz foo-baz (default (+ 40 2))))
  51     (and (match (foo (bar 1) (baz 2))
  52            (($ <foo> 1 2) #t))
  53          (match (foo (baz 2) (bar 1))
  54            (($ <foo> 1 2) #t))
  55          (match (foo (bar 1))
  56            (($ <foo> 1 42) #t)))))
  57
  58 (test-assert "define-record-type* with let* behavior"
  59   ;; Make sure field initializers can refer to each other as if they were in
  60   ;; a 'let*'.
  61   (begin
  62     (define-record-type* <bar> bar make-bar
  63       foo?
  64       (x bar-x)
  65       (y bar-y (default (+ 40 2)))
  66       (z bar-z))
  67     (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
  68            (($ <bar> 1 2 4) #t))
  69          (match (bar (x 7) (z (* x 3)))
  70            (($ <bar> 7 42 21) #t))
  71          (match (bar (z 21) (x (/ z 3)))
  72            (($ <bar> 7 42 21) #t)))))
  73
  74 (test-assert "define-record-type* & inherit"
  75   (begin
  76     (define-record-type* <foo> foo make-foo
  77       foo?
  78       (bar foo-bar)
  79       (baz foo-baz (default (+ 40 2))))
  80     (let* ((a (foo (bar 1)))
  81            (b (foo (inherit a) (baz 2)))
  82            (c (foo (inherit b) (bar -2)))
  83            (d (foo (inherit c)))
  84            (e (foo (inherit (foo (bar 42))) (baz 77))))
  85      (and (match a (($ <foo> 1 42) #t))
  86           (match b (($ <foo> 1 2) #t))
  87           (match c (($ <foo> -2 2) #t))
  88           (equal? c d)
  89           (match e (($ <foo> 42 77) #t))))))
  90
  91 (test-assert "define-record-type* & inherit & let* behavior"
  92   (begin
  93     (define-record-type* <foo> foo make-foo
  94       foo?
  95       (bar foo-bar)
  96       (baz foo-baz (default (+ 40 2))))
  97     (let* ((a (foo (bar 77)))
  98            (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
  99            (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
 100      (and (match a (($ <foo> 77 42) #t))
 101           (match b (($ <foo> 1 2) #t))
 102           (equal? b c)))))
 103
 104 (test-assert "define-record-type* & inherit & innate"
 105   (begin
 106     (define-record-type* <foo> foo make-foo
 107       foo?
 108       (bar foo-bar (innate) (default 42)))
 109     (let* ((a (foo (bar 1)))
 110            (b (foo (inherit a)))
 111            (c (foo (inherit a) (bar 3)))
 112            (d (foo)))
 113       (and (match a (($ <foo> 1) #t))
 114            (match b (($ <foo> 42) #t))
 115            (match c (($ <foo> 3) #t))
 116            (match d (($ <foo> 42) #t))))))
 117
 118 (test-assert "define-record-type* & thunked"
 119   (begin
 120     (define-record-type* <foo> foo make-foo
 121       foo?
 122       (bar foo-bar)
 123       (baz foo-baz (thunked)))
 124
 125     (let* ((calls 0)
 126            (x     (foo (bar 2)
 127                        (baz (begin (set! calls (1+ calls)) 3)))))
 128       (and (zero? calls)
 129            (equal? (foo-bar x) 2)
 130            (equal? (foo-baz x) 3) (= 1 calls)
 131            (equal? (foo-baz x) 3) (= 2 calls)))))
 132
 133 (test-assert "define-record-type* & thunked & default"
 134   (begin
 135     (define-record-type* <foo> foo make-foo
 136       foo?
 137       (bar foo-bar)
 138       (baz foo-baz (thunked) (default 42)))
 139
 140     (let ((mark (make-parameter #f)))
 141       (let ((x (foo (bar 2) (baz (mark))))
 142             (y (foo (bar 2))))
 143         (and (equal? (foo-bar x) 2)
 144              (parameterize ((mark (cons 'a 'b)))
 145                (eq? (foo-baz x) (mark)))
 146              (equal? (foo-bar y) 2)
 147              (equal? (foo-baz y) 42))))))
 148
 149 (test-assert "define-record-type* & thunked & inherited"
 150   (begin
 151     (define-record-type* <foo> foo make-foo
 152       foo?
 153       (bar foo-bar (thunked))
 154       (baz foo-baz (thunked) (default 42)))
 155
 156     (let ((mark (make-parameter #f)))
 157       (let* ((x (foo (bar 2) (baz (mark))))
 158              (y (foo (inherit x) (bar (mark)))))
 159         (and (equal? (foo-bar x) 2)
 160              (parameterize ((mark (cons 'a 'b)))
 161                (eq? (foo-baz x) (mark)))
 162              (parameterize ((mark (cons 'a 'b)))
 163                (eq? (foo-bar y) (mark)))
 164              (parameterize ((mark (cons 'a 'b)))
 165                (eq? (foo-baz y) (mark))))))))
 166
 167 (test-assert "define-record-type* & thunked & innate"
 168   (let ((mark (make-parameter #f)))
 169     (define-record-type* <foo> foo make-foo
 170       foo?
 171       (bar foo-bar (thunked) (innate) (default (mark)))
 172       (baz foo-baz (default #f)))
 173
 174     (let* ((x (foo (bar 42)))
 175            (y (foo (inherit x) (baz 'unused))))
 176       (and (procedure? (struct-ref x 0))
 177            (equal? (foo-bar x) 42)
 178            (parameterize ((mark (cons 'a 'b)))
 179              (eq? (foo-bar y) (mark)))
 180            (parameterize ((mark (cons 'a 'b)))
 181              (eq? (foo-bar y) (mark)))))))
 182
 183 (test-assert "define-record-type* & thunked & this-record"
 184   (begin
 185     (define-record-type* <foo> foo make-foo
 186       foo?
 187       (bar foo-bar)
 188       (baz foo-baz (thunked)))
 189
 190     (let ((x (foo (bar 40)
 191                   (baz (+ (foo-bar this-record) 2)))))
 192       (and (= 40 (foo-bar x))
 193            (= 42 (foo-baz x))))))
 194
 195 (test-assert "define-record-type* & thunked & default & this-record"
 196   (begin
 197     (define-record-type* <foo> foo make-foo
 198       foo?
 199       (bar foo-bar)
 200       (baz foo-baz (thunked)
 201            (default (+ (foo-bar this-record) 2))))
 202
 203     (let ((x (foo (bar 40))))
 204       (and (= 40 (foo-bar x))
 205            (= 42 (foo-baz x))))))
 206
 207 (test-assert "define-record-type* & thunked & inherit & this-record"
 208   (begin
 209     (define-record-type* <foo> foo make-foo
 210       foo?
 211       (bar foo-bar)
 212       (baz foo-baz (thunked)
 213            (default (+ (foo-bar this-record) 2))))
 214
 215     (let* ((x (foo (bar 40)))
 216            (y (foo (inherit x) (bar -2)))
 217            (z (foo (inherit x) (baz -2))))
 218       (and (= -2 (foo-bar y))
 219            (=  0 (foo-baz y))
 220            (= 40 (foo-bar z))
 221            (= -2 (foo-baz z))))))
 222
 223 (test-assert "define-record-type* & thunked & inherit & custom this"
 224   (let ()
 225     (define-record-type* <foo> foo make-foo
 226       foo? this-foo
 227       (thing foo-thing (thunked)))
 228     (define-record-type* <bar> bar make-bar
 229       bar? this-bar
 230       (baz bar-baz (thunked)))
 231
 232     ;; Nest records and test the two self references.
 233     (let* ((x (foo (thing (bar (baz (list this-bar this-foo))))))
 234            (y (foo-thing x)))
 235       (match (bar-baz y)
 236         ((first second)
 237          (and (eq? second x)
 238               (bar? first)
 239               (eq? first y)))))))
 240
 241 (test-assert "define-record-type* & delayed"
 242   (begin
 243     (define-record-type* <foo> foo make-foo
 244       foo?
 245       (bar foo-bar (delayed)))
 246
 247     (let* ((calls 0)
 248            (x     (foo (bar (begin (set! calls (1+ calls)) 3)))))
 249       (and (zero? calls)
 250            (equal? (foo-bar x) 3) (= 1 calls)
 251            (equal? (foo-bar x) 3) (= 1 calls)
 252            (equal? (foo-bar x) 3) (= 1 calls)))))
 253
 254 (test-assert "define-record-type* & delayed & default"
 255   (let ((mark #f))
 256     (define-record-type* <foo> foo make-foo
 257       foo?
 258       (bar foo-bar (delayed) (default mark)))
 259
 260     (let ((x (foo)))
 261       (set! mark 42)
 262       (and (equal? (foo-bar x) 42)
 263            (begin
 264              (set! mark 7)
 265              (equal? (foo-bar x) 42))))))
 266
 267 (test-assert "define-record-type* & delayed & inherited"
 268   (begin
 269     (define-record-type* <foo> foo make-foo
 270       foo?
 271       (bar foo-bar (delayed))
 272       (baz foo-baz (delayed)))
 273
 274     (let* ((m 1)
 275            (n #f)
 276            (x (foo (bar m) (baz n)))
 277            (y (foo (inherit x) (baz 'b))))
 278       (set! n 'a)
 279       (and (equal? (foo-bar x) 1)
 280            (eq? (foo-baz x) 'a)
 281            (begin
 282              (set! m 777)
 283              (equal? (foo-bar y) 1))              ;promise was already forced
 284            (eq? (foo-baz y) 'b)))))
 285
 286 (test-assert "define-record-type* & sanitize"
 287   (begin
 288     (define-record-type* <foo> foo make-foo
 289       foo?
 290       (bar foo-bar
 291            (default "bar")
 292            (sanitize (lambda (x) (string-append x "!")))))
 293
 294     (let* ((p (foo))
 295            (q (foo (inherit p)))
 296            (r (foo (inherit p) (bar "baz")))
 297            (s (foo (bar "baz"))))
 298       (and (string=? (foo-bar p) "bar!")
 299            (equal? q p)
 300            (string=? (foo-bar r) "baz!")
 301            (equal? s r)))))
 302
 303 (test-equal "define-record-type* & sanitize without default value"
 304   42
 305   (begin
 306     (define-record-type* <foo> foo make-foo
 307       foo?
 308       (bar foo-bar (sanitize 1+)))
 309
 310     (foo-bar (foo (bar 41)))))
 311
 312 (test-assert "define-record-type* & sanitize & thunked"
 313   (let ((sanitized 0))
 314     (define-record-type* <foo> foo make-foo
 315       foo?
 316       (bar foo-bar
 317            (default "bar")
 318            (sanitize (lambda (x)
 319                        (set! sanitized (+ 1 sanitized))
 320                        (string-append x "!")))))
 321
 322     (let ((p (foo)))
 323       (and (string=? (foo-bar p) "bar!")
 324            (string=? (foo-bar p) "bar!")          ;twice
 325            (= sanitized 1)             ;sanitizer was called at init time only
 326            (let ((q (foo (bar "baz"))))
 327              (and (string=? (foo-bar q) "baz!")
 328                   (string=? (foo-bar q) "baz!")   ;twice
 329                   (= sanitized 2)
 330                   (let ((r (foo (inherit q))))
 331                     (and (string=? (foo-bar r) "baz!")
 332                          (= sanitized 2)))))))))  ;no re-sanitization
 333
 334 (test-assert "define-record-type* & wrong field specifier"
 335   (let ((exp '(begin
 336                 (define-record-type* <foo> foo make-foo
 337                   foo?
 338                   (bar foo-bar (default 42))
 339                   (baz foo-baz))
 340
 341                 (foo (baz 1 2 3 4 5))))           ;syntax error
 342         (loc         (current-source-location)))  ;keep this alignment!
 343     (catch 'syntax-error
 344       (lambda ()
 345         (eval exp (test-module))
 346         #f)
 347       (lambda (key proc message location form subform . _)
 348         (and (eq? proc 'foo)
 349              (string-match "invalid field" message)
 350              (equal? subform '(baz 1 2 3 4 5))
 351              (equal? form '(foo (baz 1 2 3 4 5)))
 352
 353              ;; Make sure the location is that of the field specifier.
 354              ;; See <http://bugs.gnu.org/23969>.
 355              (lset= equal?
 356                     (pk 'expected-loc
 357                         `((line . ,(- (assq-ref loc 'line) 1))
 358                           ,@(alist-delete 'line loc)))
 359                     (pk 'actual-loc (location-alist location))))))))
 360
 361 (test-assert "define-record-type* & wrong field specifier, identifier"
 362   (let ((exp '(begin
 363                 (define-record-type* <foo> foo make-foo
 364                   foo?
 365                   (bar foo-bar (default 42))
 366                   (baz foo-baz))
 367
 368                 (foo
 369                  baz)))                           ;syntax error
 370         (loc    (current-source-location)))       ;keep this alignment!
 371     (catch 'syntax-error
 372       (lambda ()
 373         (eval exp (test-module))
 374         #f)
 375       (lambda (key proc message location form subform . _)
 376         (and (eq? proc 'foo)
 377              (string-match "invalid field" message)
 378              (equal? subform 'baz)
 379              (equal? form '(foo baz))
 380
 381              ;; Here the location is that of the parent form.
 382              (lset= equal?
 383                     (pk 'expected-loc
 384                         `((line . ,(- (assq-ref loc 'line) 2))
 385                           ,@(alist-delete 'line loc)))
 386                     (pk 'actual-loc (location-alist location))))))))
 387
 388 (test-assert "define-record-type* & missing initializers"
 389   (catch 'syntax-error
 390     (lambda ()
 391       (eval '(begin
 392                (define-record-type* <foo> foo make-foo
 393                  foo?
 394                  (bar foo-bar (default 42))
 395                  (baz foo-baz))
 396
 397                (foo))
 398             (test-module))
 399       #f)
 400     (lambda (key proc message location form . args)
 401       (and (eq? proc 'foo)
 402            (string-match "missing .*initialize.*baz" message)
 403            (equal? form '(foo))))))
 404
 405 (test-assert "define-record-type* & extra initializers"
 406   (catch 'syntax-error
 407     (lambda ()
 408       (eval '(begin
 409                (define-record-type* <foo> foo make-foo
 410                  foo?
 411                  (bar foo-bar (default 42)))
 412
 413                (foo (baz 'what?)))
 414             (test-module))
 415       #f)
 416     (lambda (key proc message location form . args)
 417       (and (string-match "extra.*initializer.*baz" message)
 418            (eq? proc 'foo)))))
 419
 420 (test-assert "define-record-type* & inherit & extra initializers"
 421   (catch 'syntax-error
 422     (lambda ()
 423       (eval '(begin
 424                (define-record-type* <foo> foo make-foo
 425                  foo?
 426                  (bar foo-bar (default 42)))
 427
 428                (foo (inherit (foo)) (baz 'what?)))
 429             (test-module))
 430       #f)
 431     (lambda (key proc message location form . args)
 432       (and (string-match "extra.*initializer.*baz" message)
 433            (eq? proc 'foo)))))
 434
 435 (test-assert "define-record-type* & duplicate initializers"
 436   (let ((exp '(begin
 437                 (define-record-type* <foo> foo make-foo
 438                   foo?
 439                   (bar foo-bar (default 42)))
 440
 441                 (foo (bar 1)
 442                      (bar 2))))
 443         (loc         (current-source-location)))  ;keep this alignment!
 444     (catch 'syntax-error
 445       (lambda ()
 446         (eval exp (test-module))
 447         #f)
 448       (lambda (key proc message location form . args)
 449         (and (string-match "duplicate.*initializer" message)
 450              (eq? proc 'foo)
 451
 452              ;; Make sure the location is that of the field specifier.
 453              (lset= equal?
 454                     (pk 'expected-loc
 455                         `((line . ,(- (assq-ref loc 'line) 1))
 456                           ,@(alist-delete 'line loc)))
 457                     (pk 'actual-loc (location-alist location))))))))
 458
 459 (test-assert "ABI checks"
 460   (let ((module (test-module)))
 461     (eval '(begin
 462              (define-record-type* <foo> foo make-foo
 463                foo?
 464                (bar foo-bar (default 42)))
 465
 466              (define (make-me-a-record) (foo)))
 467           module)
 468     (unless (eval '(foo? (make-me-a-record)) module)
 469       (error "what?" (eval '(make-me-a-record) module)))
 470
 471     ;; Redefine <foo> with an additional field.
 472     (eval '(define-record-type* <foo> foo make-foo
 473              foo?
 474              (baz foo-baz)
 475              (bar foo-bar (default 42)))
 476           module)
 477
 478     ;; Now 'make-me-a-record' is out of sync because it does an
 479     ;; 'allocate-struct' that corresponds to the previous definition of <foo>.
 480     (catch 'record-abi-mismatch-error
 481       (lambda ()
 482         (eval '(foo? (make-me-a-record)) module)
 483         #f)
 484       (match-lambda*
 485         ((key 'abi-check (? string? message) (rtd) . _)
 486          (eq? rtd (eval '<foo> module)))))))
 487
 488 (test-equal "recutils->alist"
 489   '((("Name" . "foo")
 490      ("Version" . "0.1")
 491      ("Synopsis" . "foo bar")
 492      ("Something_else" . "chbouib"))
 493     (("Name" . "bar")
 494      ("Version" . "1.5")))
 495   (let ((p (open-input-string "
 496 # Comment following an empty line, and
 497 # preceding a couple of empty lines, all of
 498 # which should be silently consumed.
 499
 500
 501 Name: foo
 502 Version: 0.1
 503 # Comment right in the middle,
 504 # spanning two lines.
 505 Synopsis: foo bar
 506 Something_else: chbouib
 507
 508 # Comment right before.
 509 Name: bar
 510 Version: 1.5
 511 # Comment at the end.")))
 512     (list (recutils->alist p)
 513           (recutils->alist p))))
 514
 515 (test-equal "recutils->alist with + lines"
 516   '(("Name" . "foo")
 517     ("Description" . "1st line,\n2nd line,\n 3rd line with extra space,\n4th line without space."))
 518   (recutils->alist (open-input-string "
 519 Name: foo
 520 Description: 1st line,
 521 + 2nd line,
 522 +  3rd line with extra space,
 523 +4th line without space.")))
 524
 525 (test-equal "alist->record" '((1 2) b c)
 526   (alist->record '(("a" . 1) ("b" . b) ("c" . c) ("a" . 2))
 527                  list
 528                  '("a" "b" "c")
 529                  '("a")))
 530
 531 (test-end)