tests/records.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015 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-64)
  21   #:use-module (ice-9 match)
  22   #:use-module (ice-9 regex)
  23   #:use-module (guix records))
  24
  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
  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
  47 (test-assert "define-record-type* with let* behavior"
  48   ;; Make sure field initializers can refer to each other as if they were in
  49   ;; a 'let*'.
  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)))
  59            (($ <bar> 7 42 21) #t))
  60          (match (bar (z 21) (x (/ z 3)))
  61            (($ <bar> 7 42 21) #t)))))
  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
  80 (test-assert "define-record-type* & inherit & let* behavior"
  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
  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
 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
 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
 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
 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
 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
 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")))
 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
 278 Version: 0.1
 279 # Comment right in the middle,
 280 # spanning two lines.
 281 Synopsis: foo bar
 282 Something_else: chbouib
 283
 284 # Comment right before.
 285 Name: bar
 286 Version: 1.5
 287 # Comment at the end.")))
 288     (list (recutils->alist p)
 289           (recutils->alist p))))
 290
 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
 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
 307 (test-end)
 308
 309 \f
 310 (exit (= (test-runner-fail-count (test-runner-current)) 0))