all messages for Guix-related lists mirrored at yhetil.org

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
 (define-module (unit-tests)
  #:use-module (guix gexp)
  #:use-module (guix diagnostics)
  #:use-module (guix records)
  #:use-module ((guix ui) #:select (warn-about-load-error))
  #:use-module (guix discovery)
  #:use-module (srfi srfi-9 gnu)
  #:use-module (ice-9 match)
  #:export (unit-test
            unit-test?
            unit-test-name
            unit-test-value
            unit-test-description
            unit-test-location

            fold-unit-tests
            all-unit-tests))

\f
;;;
;;; Unit tests.
;;;

(define-record-type* <unit-test> unit-test make-unit-test
  unit-test?
  (name        unit-test-name)                  ;string
  (value       unit-test-value)                 ;%STORE-MONAD value
  (description unit-test-description)           ;string
  (location    unit-test-location (innate)      ;<location>
               (default (and=> (current-source-location)
                               source-properties->location))))

(define (write-unit-test test port)
  (match test
    (($ <unit-test> name _ _ ($ <location> file line))
     (format port "#<unit-test ~a ~a:~a ~a>"
             name file line
             (number->string (object-address test) 16)))
    (($ <unit-test> name)
     (format port "#<unit-test ~a ~a>" name
             (number->string (object-address test) 16)))))

(set-record-type-printer! <unit-test> write-unit-test)

(define-gexp-compiler (compile-unit-test (test <unit-test>)
                                           unit target)
  "Compile TEST to a derivation."
  ;; XXX: UNIT and TARGET are ignored.
  (unit-test-value test))

(define (test-modules)
  "Return the list of modules that define unit tests."
  (scheme-modules (dirname (search-path %load-path "guix.scm"))
                  "tests"
                  #:warn warn-about-load-error))

(define (fold-unit-tests proc seed)
  "Invoke PROC on each unit test, passing it the test and the previous
result."
  (fold-module-public-variables (lambda (obj result)
                                  (if (unit-test? obj)
                                      (cons obj result)
                                      result))
                                '()
                                (test-modules)))

(define (all-unit-tests)
  "Return the list of unit tests."
  (reverse (fold-unit-tests cons '())))