tests/records.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2018, 2019 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 \f
  33 (test-begin "records")
  34
  35 (test-assert "define-record-type*"
  36   (begin
  37     (define-record-type* <foo> foo make-foo
  38       foo?
  39       (bar foo-bar)
  40       (baz foo-baz (default (+ 40 2))))
  41     (and (match (foo (bar 1) (baz 2))
  42            (($ <foo> 1 2) #t))
  43          (match (foo (baz 2) (bar 1))
  44            (($ <foo> 1 2) #t))
  45          (match (foo (bar 1))
  46            (($ <foo> 1 42) #t)))))
  47
  48 (test-assert "define-record-type* with let* behavior"
  49   ;; Make sure field initializers can refer to each other as if they were in
  50   ;; a 'let*'.
  51   (begin
  52     (define-record-type* <bar> bar make-bar
  53       foo?
  54       (x bar-x)
  55       (y bar-y (default (+ 40 2)))
  56       (z bar-z))
  57     (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
  58            (($ <bar> 1 2 4) #t))
  59          (match (bar (x 7) (z (* x 3)))
  60            (($ <bar> 7 42 21) #t))
  61          (match (bar (z 21) (x (/ z 3)))
  62            (($ <bar> 7 42 21) #t)))))
  63
  64 (test-assert "define-record-type* & inherit"
  65   (begin
  66     (define-record-type* <foo> foo make-foo
  67       foo?
  68       (bar foo-bar)
  69       (baz foo-baz (default (+ 40 2))))
  70     (let* ((a (foo (bar 1)))
  71            (b (foo (inherit a) (baz 2)))
  72            (c (foo (inherit b) (bar -2)))
  73            (d (foo (inherit c)))
  74            (e (foo (inherit (foo (bar 42))) (baz 77))))
  75      (and (match a (($ <foo> 1 42) #t))
  76           (match b (($ <foo> 1 2) #t))
  77           (match c (($ <foo> -2 2) #t))
  78           (equal? c d)
  79           (match e (($ <foo> 42 77) #t))))))
  80
  81 (test-assert "define-record-type* & inherit & let* behavior"
  82   (begin
  83     (define-record-type* <foo> foo make-foo
  84       foo?
  85       (bar foo-bar)
  86       (baz foo-baz (default (+ 40 2))))
  87     (let* ((a (foo (bar 77)))
  88            (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
  89            (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
  90      (and (match a (($ <foo> 77 42) #t))
  91           (match b (($ <foo> 1 2) #t))
  92           (equal? b c)))))
  93
  94 (test-assert "define-record-type* & inherit & innate"
  95   (begin
  96     (define-record-type* <foo> foo make-foo
  97       foo?
  98       (bar foo-bar (innate) (default 42)))
  99     (let* ((a (foo (bar 1)))
 100            (b (foo (inherit a)))
 101            (c (foo (inherit a) (bar 3)))
 102            (d (foo)))
 103       (and (match a (($ <foo> 1) #t))
 104            (match b (($ <foo> 42) #t))
 105            (match c (($ <foo> 3) #t))
 106            (match d (($ <foo> 42) #t))))))
 107
 108 (test-assert "define-record-type* & thunked"
 109   (begin
 110     (define-record-type* <foo> foo make-foo
 111       foo?
 112       (bar foo-bar)
 113       (baz foo-baz (thunked)))
 114
 115     (let* ((calls 0)
 116            (x     (foo (bar 2)
 117                        (baz (begin (set! calls (1+ calls)) 3)))))
 118       (and (zero? calls)
 119            (equal? (foo-bar x) 2)
 120            (equal? (foo-baz x) 3) (= 1 calls)
 121            (equal? (foo-baz x) 3) (= 2 calls)))))
 122
 123 (test-assert "define-record-type* & thunked & default"
 124   (begin
 125     (define-record-type* <foo> foo make-foo
 126       foo?
 127       (bar foo-bar)
 128       (baz foo-baz (thunked) (default 42)))
 129
 130     (let ((mark (make-parameter #f)))
 131       (let ((x (foo (bar 2) (baz (mark))))
 132             (y (foo (bar 2))))
 133         (and (equal? (foo-bar x) 2)
 134              (parameterize ((mark (cons 'a 'b)))
 135                (eq? (foo-baz x) (mark)))
 136              (equal? (foo-bar y) 2)
 137              (equal? (foo-baz y) 42))))))
 138
 139 (test-assert "define-record-type* & thunked & inherited"
 140   (begin
 141     (define-record-type* <foo> foo make-foo
 142       foo?
 143       (bar foo-bar (thunked))
 144       (baz foo-baz (thunked) (default 42)))
 145
 146     (let ((mark (make-parameter #f)))
 147       (let* ((x (foo (bar 2) (baz (mark))))
 148              (y (foo (inherit x) (bar (mark)))))
 149         (and (equal? (foo-bar x) 2)
 150              (parameterize ((mark (cons 'a 'b)))
 151                (eq? (foo-baz x) (mark)))
 152              (parameterize ((mark (cons 'a 'b)))
 153                (eq? (foo-bar y) (mark)))
 154              (parameterize ((mark (cons 'a 'b)))
 155                (eq? (foo-baz y) (mark))))))))
 156
 157 (test-assert "define-record-type* & thunked & innate"
 158   (let ((mark (make-parameter #f)))
 159     (define-record-type* <foo> foo make-foo
 160       foo?
 161       (bar foo-bar (thunked) (innate) (default (mark)))
 162       (baz foo-baz (default #f)))
 163
 164     (let* ((x (foo (bar 42)))
 165            (y (foo (inherit x) (baz 'unused))))
 166       (and (procedure? (struct-ref x 0))
 167            (equal? (foo-bar x) 42)
 168            (parameterize ((mark (cons 'a 'b)))
 169              (eq? (foo-bar y) (mark)))
 170            (parameterize ((mark (cons 'a 'b)))
 171              (eq? (foo-bar y) (mark)))))))
 172
 173 (test-assert "define-record-type* & thunked & this-record"
 174   (begin
 175     (define-record-type* <foo> foo make-foo
 176       foo?
 177       (bar foo-bar)
 178       (baz foo-baz (thunked)))
 179
 180     (let ((x (foo (bar 40)
 181                   (baz (+ (foo-bar this-record) 2)))))
 182       (and (= 40 (foo-bar x))
 183            (= 42 (foo-baz x))))))
 184
 185 (test-assert "define-record-type* & thunked & default & this-record"
 186   (begin
 187     (define-record-type* <foo> foo make-foo
 188       foo?
 189       (bar foo-bar)
 190       (baz foo-baz (thunked)
 191            (default (+ (foo-bar this-record) 2))))
 192
 193     (let ((x (foo (bar 40))))
 194       (and (= 40 (foo-bar x))
 195            (= 42 (foo-baz x))))))
 196
 197 (test-assert "define-record-type* & thunked & inherit & this-record"
 198   (begin
 199     (define-record-type* <foo> foo make-foo
 200       foo?
 201       (bar foo-bar)
 202       (baz foo-baz (thunked)
 203            (default (+ (foo-bar this-record) 2))))
 204
 205     (let* ((x (foo (bar 40)))
 206            (y (foo (inherit x) (bar -2)))
 207            (z (foo (inherit x) (baz -2))))
 208       (and (= -2 (foo-bar y))
 209            (=  0 (foo-baz y))
 210            (= 40 (foo-bar z))
 211            (= -2 (foo-baz z))))))
 212
 213 (test-assert "define-record-type* & thunked & inherit & custom this"
 214   (let ()
 215     (define-record-type* <foo> foo make-foo
 216       foo? this-foo
 217       (thing foo-thing (thunked)))
 218     (define-record-type* <bar> bar make-bar
 219       bar? this-bar
 220       (baz bar-baz (thunked)))
 221
 222     ;; Nest records and test the two self references.
 223     (let* ((x (foo (thing (bar (baz (list this-bar this-foo))))))
 224            (y (foo-thing x)))
 225       (match (bar-baz y)
 226         ((first second)
 227          (and (eq? second x)
 228               (bar? first)
 229               (eq? first y)))))))
 230
 231 (test-assert "define-record-type* & delayed"
 232   (begin
 233     (define-record-type* <foo> foo make-foo
 234       foo?
 235       (bar foo-bar (delayed)))
 236
 237     (let* ((calls 0)
 238            (x     (foo (bar (begin (set! calls (1+ calls)) 3)))))
 239       (and (zero? calls)
 240            (equal? (foo-bar x) 3) (= 1 calls)
 241            (equal? (foo-bar x) 3) (= 1 calls)
 242            (equal? (foo-bar x) 3) (= 1 calls)))))
 243
 244 (test-assert "define-record-type* & delayed & default"
 245   (let ((mark #f))
 246     (define-record-type* <foo> foo make-foo
 247       foo?
 248       (bar foo-bar (delayed) (default mark)))
 249
 250     (let ((x (foo)))
 251       (set! mark 42)
 252       (and (equal? (foo-bar x) 42)
 253            (begin
 254              (set! mark 7)
 255              (equal? (foo-bar x) 42))))))
 256
 257 (test-assert "define-record-type* & delayed & inherited"
 258   (begin
 259     (define-record-type* <foo> foo make-foo
 260       foo?
 261       (bar foo-bar (delayed))
 262       (baz foo-baz (delayed)))
 263
 264     (let* ((m 1)
 265            (n #f)
 266            (x (foo (bar m) (baz n)))
 267            (y (foo (inherit x) (baz 'b))))
 268       (set! n 'a)
 269       (and (equal? (foo-bar x) 1)
 270            (eq? (foo-baz x) 'a)
 271            (begin
 272              (set! m 777)
 273              (equal? (foo-bar y) 1))              ;promise was already forced
 274            (eq? (foo-baz y) 'b)))))
 275
 276 (test-assert "define-record-type* & wrong field specifier"
 277   (let ((exp '(begin
 278                 (define-record-type* <foo> foo make-foo
 279                   foo?
 280                   (bar foo-bar (default 42))
 281                   (baz foo-baz))
 282
 283                 (foo (baz 1 2 3 4 5))))           ;syntax error
 284         (loc         (current-source-location)))  ;keep this alignment!
 285     (catch 'syntax-error
 286       (lambda ()
 287         (eval exp (test-module))
 288         #f)
 289       (lambda (key proc message location form . args)
 290         (and (eq? proc 'foo)
 291              (string-match "invalid field" message)
 292              (equal? form '(baz 1 2 3 4 5))
 293
 294              ;; Make sure the location is that of the field specifier.
 295              ;; See <http://bugs.gnu.org/23969>.
 296              (lset= equal?
 297                     (pk 'expected-loc
 298                         `((line . ,(- (assq-ref loc 'line) 1))
 299                           ,@(alist-delete 'line loc)))
 300                     (pk 'actual-loc location)))))))
 301
 302 (test-assert "define-record-type* & missing initializers"
 303   (catch 'syntax-error
 304     (lambda ()
 305       (eval '(begin
 306                (define-record-type* <foo> foo make-foo
 307                  foo?
 308                  (bar foo-bar (default 42))
 309                  (baz foo-baz))
 310
 311                (foo))
 312             (test-module))
 313       #f)
 314     (lambda (key proc message location form . args)
 315       (and (eq? proc 'foo)
 316            (string-match "missing .*initialize.*baz" message)
 317            (equal? form '(foo))))))
 318
 319 (test-assert "define-record-type* & extra initializers"
 320   (catch 'syntax-error
 321     (lambda ()
 322       (eval '(begin
 323                (define-record-type* <foo> foo make-foo
 324                  foo?
 325                  (bar foo-bar (default 42)))
 326
 327                (foo (baz 'what?)))
 328             (test-module))
 329       #f)
 330     (lambda (key proc message location form . args)
 331       (and (string-match "extra.*initializer.*baz" message)
 332            (eq? proc 'foo)))))
 333
 334 (test-assert "define-record-type* & inherit & extra initializers"
 335   (catch 'syntax-error
 336     (lambda ()
 337       (eval '(begin
 338                (define-record-type* <foo> foo make-foo
 339                  foo?
 340                  (bar foo-bar (default 42)))
 341
 342                (foo (inherit (foo)) (baz 'what?)))
 343             (test-module))
 344       #f)
 345     (lambda (key proc message location form . args)
 346       (and (string-match "extra.*initializer.*baz" message)
 347            (eq? proc 'foo)))))
 348
 349 (test-assert "define-record-type* & duplicate initializers"
 350   (let ((exp '(begin
 351                 (define-record-type* <foo> foo make-foo
 352                   foo?
 353                   (bar foo-bar (default 42)))
 354
 355                 (foo (bar 1)
 356                      (bar 2))))
 357         (loc         (current-source-location)))  ;keep this alignment!
 358     (catch 'syntax-error
 359       (lambda ()
 360         (eval exp (test-module))
 361         #f)
 362       (lambda (key proc message location form . args)
 363         (and (string-match "duplicate.*initializer" message)
 364              (eq? proc 'foo)
 365
 366              ;; Make sure the location is that of the field specifier.
 367              (lset= equal?
 368                     (pk 'expected-loc
 369                         `((line . ,(- (assq-ref loc 'line) 1))
 370                           ,@(alist-delete 'line loc)))
 371                     (pk 'actual-loc location)))))))
 372
 373 (test-assert "ABI checks"
 374   (let ((module (test-module)))
 375     (eval '(begin
 376              (define-record-type* <foo> foo make-foo
 377                foo?
 378                (bar foo-bar (default 42)))
 379
 380              (define (make-me-a-record) (foo)))
 381           module)
 382     (unless (eval '(foo? (make-me-a-record)) module)
 383       (error "what?" (eval '(make-me-a-record) module)))
 384
 385     ;; Redefine <foo> with an additional field.
 386     (eval '(define-record-type* <foo> foo make-foo
 387              foo?
 388              (baz foo-baz)
 389              (bar foo-bar (default 42)))
 390           module)
 391
 392     ;; Now 'make-me-a-record' is out of sync because it does an
 393     ;; 'allocate-struct' that corresponds to the previous definition of <foo>.
 394     (catch 'record-abi-mismatch-error
 395       (lambda ()
 396         (eval '(foo? (make-me-a-record)) module)
 397         #f)
 398       (match-lambda*
 399         ((key 'abi-check (? string? message) (rtd) . _)
 400          (eq? rtd (eval '<foo> module)))))))
 401
 402 (test-equal "recutils->alist"
 403   '((("Name" . "foo")
 404      ("Version" . "0.1")
 405      ("Synopsis" . "foo bar")
 406      ("Something_else" . "chbouib"))
 407     (("Name" . "bar")
 408      ("Version" . "1.5")))
 409   (let ((p (open-input-string "
 410 # Comment following an empty line, and
 411 # preceding a couple of empty lines, all of
 412 # which should be silently consumed.
 413
 414
 415 Name: foo
 416 Version: 0.1
 417 # Comment right in the middle,
 418 # spanning two lines.
 419 Synopsis: foo bar
 420 Something_else: chbouib
 421
 422 # Comment right before.
 423 Name: bar
 424 Version: 1.5
 425 # Comment at the end.")))
 426     (list (recutils->alist p)
 427           (recutils->alist p))))
 428
 429 (test-equal "recutils->alist with + lines"
 430   '(("Name" . "foo")
 431     ("Description" . "1st line,\n2nd line,\n 3rd line with extra space,\n4th line without space."))
 432   (recutils->alist (open-input-string "
 433 Name: foo
 434 Description: 1st line,
 435 + 2nd line,
 436 +  3rd line with extra space,
 437 +4th line without space.")))
 438
 439 (test-equal "alist->record" '((1 2) b c)
 440   (alist->record '(("a" . 1) ("b" . b) ("c" . c) ("a" . 2))
 441                  list
 442                  '("a" "b" "c")
 443                  '("a")))
 444
 445 (test-end)