tests/utils.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013 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-utils)
  20   #:use-module (guix utils)
  21   #:use-module ((guix store) #:select (%store-prefix store-path-package-name))
  22   #:use-module (srfi srfi-1)
  23   #:use-module (srfi srfi-11)
  24   #:use-module (srfi srfi-64)
  25   #:use-module (rnrs bytevectors)
  26   #:use-module (ice-9 match))
  27
  28 (test-begin "utils")
  29
  30 (test-assert "bytevector->base16-string->bytevector"
  31   (every (lambda (bv)
  32            (equal? (base16-string->bytevector
  33                     (bytevector->base16-string bv))
  34                    bv))
  35          (map string->utf8 '("" "f" "fo" "foo" "foob" "fooba" "foobar"))))
  36
  37 (test-assert "gnu-triplet->nix-system"
  38   (let ((samples '(("i586-gnu0.3" "i686-gnu")
  39                    ("x86_64-unknown-linux-gnu" "x86_64-linux")
  40                    ("i386-pc-linux-gnu" "i686-linux")
  41                    ("x86_64-unknown-freebsd8.2" "x86_64-freebsd")
  42                    ("x86_64-apple-darwin10.8.0" "x86_64-darwin")
  43                    ("i686-pc-cygwin" "i686-cygwin"))))
  44     (let-values (((gnu nix) (unzip2 samples)))
  45       (every (lambda (gnu nix)
  46                (equal? nix (gnu-triplet->nix-system gnu)))
  47              gnu nix))))
  48
  49 (test-assert "package-name->name+version"
  50   (every (match-lambda
  51           ((name version)
  52            (let*-values (((full-name)
  53                           (if version
  54                               (string-append name "-" version)
  55                               name))
  56                          ((name* version*)
  57                           (package-name->name+version full-name)))
  58              (and (equal? name* name)
  59                   (equal? version* version)))))
  60          '(("foo" "0.9.1b")
  61            ("foo-bar" "1.0")
  62            ("foo-bar2" #f)
  63            ("guile" "2.0.6.65-134c9") ; as produced by `git-version-gen'
  64            ("nixpkgs" "1.0pre22125_a28fe19")
  65            ("gtk2" "2.38.0"))))
  66
  67 (test-assert "define-record-type*"
  68   (begin
  69     (define-record-type* <foo> foo make-foo
  70       foo?
  71       (bar foo-bar)
  72       (baz foo-baz (default (+ 40 2))))
  73     (and (match (foo (bar 1) (baz 2))
  74            (($ <foo> 1 2) #t))
  75          (match (foo (baz 2) (bar 1))
  76            (($ <foo> 1 2) #t))
  77          (match (foo (bar 1))
  78            (($ <foo> 1 42) #t)))))
  79
  80 (test-assert "define-record-type* with letrec* behavior"
  81   ;; Make sure field initializers can refer to each other as if they were in
  82   ;; a `letrec*'.
  83   (begin
  84     (define-record-type* <bar> bar make-bar
  85       foo?
  86       (x bar-x)
  87       (y bar-y (default (+ 40 2)))
  88       (z bar-z))
  89     (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
  90            (($ <bar> 1 2 4) #t))
  91          (match (bar (x 7) (z (* x 3)))
  92            (($ <bar> 7 42 21)))
  93          (match (bar (z 21) (x (/ z 3)))
  94            (($ <bar> 7 42 21))))))
  95
  96 (test-assert "define-record-type* & inherit"
  97   (begin
  98     (define-record-type* <foo> foo make-foo
  99       foo?
 100       (bar foo-bar)
 101       (baz foo-baz (default (+ 40 2))))
 102     (let* ((a (foo (bar 1)))
 103            (b (foo (inherit a) (baz 2)))
 104            (c (foo (inherit b) (bar -2)))
 105            (d (foo (inherit c)))
 106            (e (foo (inherit (foo (bar 42))) (baz 77))))
 107      (and (match a (($ <foo> 1 42) #t))
 108           (match b (($ <foo> 1 2) #t))
 109           (match c (($ <foo> -2 2) #t))
 110           (equal? c d)
 111           (match e (($ <foo> 42 77) #t))))))
 112
 113 (test-assert "define-record-type* & inherit & letrec* behavior"
 114   (begin
 115     (define-record-type* <foo> foo make-foo
 116       foo?
 117       (bar foo-bar)
 118       (baz foo-baz (default (+ 40 2))))
 119     (let* ((a (foo (bar 77)))
 120            (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
 121            (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
 122      (and (match a (($ <foo> 77 42) #t))
 123           (match b (($ <foo> 1 2) #t))
 124           (equal? b c)))))
 125
 126 (test-assert "define-record-type* & thunked"
 127   (begin
 128     (define-record-type* <foo> foo make-foo
 129       foo?
 130       (bar foo-bar)
 131       (baz foo-baz (thunked)))
 132
 133     (let* ((calls 0)
 134            (x     (foo (bar 2)
 135                        (baz (begin (set! calls (1+ calls)) 3)))))
 136       (and (zero? calls)
 137            (equal? (foo-bar x) 2)
 138            (equal? (foo-baz x) 3) (= 1 calls)
 139            (equal? (foo-baz x) 3) (= 2 calls)))))
 140
 141 (test-assert "define-record-type* & thunked & default"
 142   (begin
 143     (define-record-type* <foo> foo make-foo
 144       foo?
 145       (bar foo-bar)
 146       (baz foo-baz (thunked) (default 42)))
 147
 148     (let ((mark (make-parameter #f)))
 149       (let ((x (foo (bar 2) (baz (mark))))
 150             (y (foo (bar 2))))
 151         (and (equal? (foo-bar x) 2)
 152              (parameterize ((mark (cons 'a 'b)))
 153                (eq? (foo-baz x) (mark)))
 154              (equal? (foo-bar y) 2)
 155              (equal? (foo-baz y) 42))))))
 156
 157 (test-assert "define-record-type* & thunked & inherited"
 158   (begin
 159     (define-record-type* <foo> foo make-foo
 160       foo?
 161       (bar foo-bar (thunked))
 162       (baz foo-baz (thunked) (default 42)))
 163
 164     (let ((mark (make-parameter #f)))
 165       (let* ((x (foo (bar 2) (baz (mark))))
 166              (y (foo (inherit x) (bar (mark)))))
 167         (and (equal? (foo-bar x) 2)
 168              (parameterize ((mark (cons 'a 'b)))
 169                (eq? (foo-baz x) (mark)))
 170              (parameterize ((mark (cons 'a 'b)))
 171                (eq? (foo-bar y) (mark)))
 172              (parameterize ((mark (cons 'a 'b)))
 173                (eq? (foo-baz y) (mark))))))))
 174
 175 ;; This is actually in (guix store).
 176 (test-equal "store-path-package-name"
 177   "bash-4.2-p24"
 178   (store-path-package-name
 179    (string-append (%store-prefix)
 180                   "/qvs2rj2ia5vci3wsdb7qvydrmacig4pg-bash-4.2-p24")))
 181
 182 (test-end)
 183
 184 \f
 185 (exit (= (test-runner-fail-count (test-runner-current)) 0))
 186
 187 ;;; Local Variables:
 188 ;;; eval: (put 'test-assert 'scheme-indent-function 1)
 189 ;;; End: