libgeda/scheme/unit-test.scm

   1 ;; Minimal Scheme unit-test framework
   2 ;; Copyright (C) 2010 Peter Brett <peter@peter-b.co.uk>
   3 ;;
   4 ;; This program is free software; you can redistribute it and/or modify
   5 ;; it under the terms of the GNU General Public License as published by
   6 ;; the Free Software Foundation; either version 2 of the License, or
   7 ;; (at your option) any later version.
   8 ;;
   9 ;; This program is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12 ;; GNU General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU General Public License
  15 ;; along with this program; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; Example of usage
  19 ;; ----------------
  20 ;;
  21 ;; The following program:
  22 ;;
  23 ;;   (use-modules (unit-test))
  24 ;;   (begin-test 'SuccessfulTest
  25 ;;     (assert-true #t)
  26 ;;     (assert-equal 1 1))
  27 ;;     (assert-thrown 'misc-error (error "Blah ~A" "Blah"))
  28 ;;   (begin-test 'FailTest
  29 ;;     (assert-equal #t "string"))
  30 ;;   (report-tests)
  31 ;;
  32 ;; Produces the output:
  33 ;;
  34 ;;   PASS: SuccessfulTest
  35 ;;   FAIL: FailTest
  36 ;;     assert-equal: expected: #t got: "string"
  37 ;;   Test summary
  38 ;;   Passed: 1
  39 ;;   Failed: 1
  40 ;;   Skipped: 0
  41 ;;
  42
  43 (define-module (unit-test)
  44   #:use-module (ice-9 pretty-print)
  45   #:export (assert-true
  46             assert-equal
  47             %assert-thrown
  48             tests-passed?
  49             report-tests
  50             %begin-test)
  51   #:export-syntax (skip-test
  52                    begin-test
  53                    assert-thrown))
  54
  55 (or (defined? 'define-syntax)
  56     (use-modules (ice-9 syncase)))
  57
  58 (define *failed-tests* '())
  59 (define *passed-tests* '())
  60 (define *skipped-tests* '())
  61
  62 (define (assert-true result)
  63   (if result
  64       #t
  65       (throw 'test-failed-exception
  66              (simple-format #f "  assert-true: got: ~S" result))))
  67
  68 (define (assert-equal expected result)
  69   (if (equal? expected result)
  70       #t
  71       (throw 'test-failed-exception
  72              (simple-format #f "  assert-equal: expected: ~S got: ~S"
  73                             expected result))))
  74
  75 (define (%assert-thrown key thunk)
  76   (catch key
  77          (lambda ()
  78            (thunk)
  79            (throw 'test-failed-exception
  80                   (simple-format #f "  assert-thrown: expected exception: ~S"
  81                                  key)))
  82          (lambda (key . args) #t)))
  83
  84 (define (%begin-test name test-thunk)
  85   (gc)
  86   (let ((test-success #t)
  87         (test-fail-msg #f))
  88
  89     (catch #t test-thunk
  90            (lambda (key . args)
  91              (set! test-success #f)
  92              (set! test-fail-msg
  93                    (if (eqv? key 'test-failed-exception)
  94                        (car args)
  95                        (format #f "  unexpected exception: ~S" (cons key args))))))
  96
  97     (if test-success
  98         (begin
  99           (format #t "PASS: ~A\n" name)
 100           (set! *passed-tests* (cons name *passed-tests*)))
 101         (begin
 102           (format #t "FAIL: ~A\n" name)
 103           (and test-fail-msg
 104                (format #t "~A\n" test-fail-msg))
 105           (set! *failed-tests* (cons name *failed-tests*))))))
 106
 107 (define-syntax begin-test
 108     (syntax-rules ()
 109       ((_ name . test-forms)
 110        (%begin-test name (lambda () . test-forms)))))
 111
 112 (define-syntax skip-test
 113   (syntax-rules ()
 114     ((_ name . test-forms)
 115      (begin
 116        (format #t "SKIP: ~A\n" name)
 117        (set! *skipped-tests* (cons name *skipped-tests*))))))
 118
 119 (define-syntax assert-thrown
 120     (syntax-rules ()
 121       ((_ key . test-forms)
 122        (%assert-thrown key (lambda () . test-forms)))))
 123
 124 (define (tests-passed?) (null? *failed-tests*))
 125
 126 (define (report-tests)
 127   (display "Test summary")(newline)
 128   (display "Passed:  ") (display (length *passed-tests*)) (newline)
 129   (display "Failed:  ") (display (length *failed-tests*)) (newline)
 130   (display "Skipped: ") (display (length *skipped-tests*)) (newline))