tests/records.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-records)
  20   #:use-module (srfi srfi-64)
  21   #:use-module (ice-9 match)
  22   #:use-module (guix records))
  23
  24 (test-begin "records")
  25
  26 (test-assert "define-record-type*"
  27   (begin
  28     (define-record-type* <foo> foo make-foo
  29       foo?
  30       (bar foo-bar)
  31       (baz foo-baz (default (+ 40 2))))
  32     (and (match (foo (bar 1) (baz 2))
  33            (($ <foo> 1 2) #t))
  34          (match (foo (baz 2) (bar 1))
  35            (($ <foo> 1 2) #t))
  36          (match (foo (bar 1))
  37            (($ <foo> 1 42) #t)))))
  38
  39 (test-assert "define-record-type* with letrec* behavior"
  40   ;; Make sure field initializers can refer to each other as if they were in
  41   ;; a `letrec*'.
  42   (begin
  43     (define-record-type* <bar> bar make-bar
  44       foo?
  45       (x bar-x)
  46       (y bar-y (default (+ 40 2)))
  47       (z bar-z))
  48     (and (match (bar (x 1) (y (+ x 1)) (z (* y 2)))
  49            (($ <bar> 1 2 4) #t))
  50          (match (bar (x 7) (z (* x 3)))
  51            (($ <bar> 7 42 21)))
  52          (match (bar (z 21) (x (/ z 3)))
  53            (($ <bar> 7 42 21))))))
  54
  55 (test-assert "define-record-type* & inherit"
  56   (begin
  57     (define-record-type* <foo> foo make-foo
  58       foo?
  59       (bar foo-bar)
  60       (baz foo-baz (default (+ 40 2))))
  61     (let* ((a (foo (bar 1)))
  62            (b (foo (inherit a) (baz 2)))
  63            (c (foo (inherit b) (bar -2)))
  64            (d (foo (inherit c)))
  65            (e (foo (inherit (foo (bar 42))) (baz 77))))
  66      (and (match a (($ <foo> 1 42) #t))
  67           (match b (($ <foo> 1 2) #t))
  68           (match c (($ <foo> -2 2) #t))
  69           (equal? c d)
  70           (match e (($ <foo> 42 77) #t))))))
  71
  72 (test-assert "define-record-type* & inherit & letrec* behavior"
  73   (begin
  74     (define-record-type* <foo> foo make-foo
  75       foo?
  76       (bar foo-bar)
  77       (baz foo-baz (default (+ 40 2))))
  78     (let* ((a (foo (bar 77)))
  79            (b (foo (inherit a) (bar 1) (baz (+ bar 1))))
  80            (c (foo (inherit b) (baz 2) (bar (- baz 1)))))
  81      (and (match a (($ <foo> 77 42) #t))
  82           (match b (($ <foo> 1 2) #t))
  83           (equal? b c)))))
  84
  85 (test-assert "define-record-type* & thunked"
  86   (begin
  87     (define-record-type* <foo> foo make-foo
  88       foo?
  89       (bar foo-bar)
  90       (baz foo-baz (thunked)))
  91
  92     (let* ((calls 0)
  93            (x     (foo (bar 2)
  94                        (baz (begin (set! calls (1+ calls)) 3)))))
  95       (and (zero? calls)
  96            (equal? (foo-bar x) 2)
  97            (equal? (foo-baz x) 3) (= 1 calls)
  98            (equal? (foo-baz x) 3) (= 2 calls)))))
  99
 100 (test-assert "define-record-type* & thunked & default"
 101   (begin
 102     (define-record-type* <foo> foo make-foo
 103       foo?
 104       (bar foo-bar)
 105       (baz foo-baz (thunked) (default 42)))
 106
 107     (let ((mark (make-parameter #f)))
 108       (let ((x (foo (bar 2) (baz (mark))))
 109             (y (foo (bar 2))))
 110         (and (equal? (foo-bar x) 2)
 111              (parameterize ((mark (cons 'a 'b)))
 112                (eq? (foo-baz x) (mark)))
 113              (equal? (foo-bar y) 2)
 114              (equal? (foo-baz y) 42))))))
 115
 116 (test-assert "define-record-type* & thunked & inherited"
 117   (begin
 118     (define-record-type* <foo> foo make-foo
 119       foo?
 120       (bar foo-bar (thunked))
 121       (baz foo-baz (thunked) (default 42)))
 122
 123     (let ((mark (make-parameter #f)))
 124       (let* ((x (foo (bar 2) (baz (mark))))
 125              (y (foo (inherit x) (bar (mark)))))
 126         (and (equal? (foo-bar x) 2)
 127              (parameterize ((mark (cons 'a 'b)))
 128                (eq? (foo-baz x) (mark)))
 129              (parameterize ((mark (cons 'a 'b)))
 130                (eq? (foo-bar y) (mark)))
 131              (parameterize ((mark (cons 'a 'b)))
 132                (eq? (foo-baz y) (mark))))))))
 133
 134 (test-equal "recutils->alist"
 135   '((("Name" . "foo")
 136      ("Version" . "0.1")
 137      ("Synopsis" . "foo bar")
 138      ("Something_else" . "chbouib"))
 139     (("Name" . "bar")
 140      ("Version" . "1.5")))
 141   (let ((p (open-input-string "
 142 # Comment following an empty line, and
 143 # preceding a couple of empty lines, all of
 144 # which should be silently consumed.
 145
 146
 147 Name: foo
 148 Version: 0.1
 149 # Comment right in the middle,
 150 # spanning two lines.
 151 Synopsis: foo bar
 152 Something_else: chbouib
 153
 154 # Comment right before.
 155 Name: bar
 156 Version: 1.5
 157 # Comment at the end.")))
 158     (list (recutils->alist p)
 159           (recutils->alist p))))
 160
 161 (test-equal "recutils->alist with + lines"
 162   '(("Name" . "foo")
 163     ("Description" . "1st line,\n2nd line,\n 3rd line with extra space,\n4th line without space."))
 164   (recutils->alist (open-input-string "
 165 Name: foo
 166 Description: 1st line,
 167 + 2nd line,
 168 +  3rd line with extra space,
 169 +4th line without space.")))
 170
 171 (test-equal "alist->record" '((1 2) b c)
 172   (alist->record '(("a" . 1) ("b" . b) ("c" . c) ("a" . 2))
 173                  list
 174                  '("a" "b" "c")
 175                  '("a")))
 176
 177 (test-end)
 178
 179 \f
 180 (exit (= (test-runner-fail-count (test-runner-current)) 0))