external/lift.darcs/test/tests-in-progress.lisp

   1 (in-package #:lift-test)
   2
   3 (deftestsuite test-a ()
   4   (a)
   5   (:cases (a '(1 2))))
   6
   7 (defmethod initialize-prototypes :after ((test test-plus))
   8   (with-test-slots (a b)
   9     (setf (prototypes test)
  10           (list
  11            (list (let* ((a 1))
  12                    (cons 'a a))
  13                  (let* ((a 2))
  14                    (cons 'a a)))))))
  15
  16 (defmethod initialize-prototypes :after ((test test-plus))
  17   (with-test-slots (a b)
  18     (setf (prototypes test)
  19           (list
  20            (list (let* ((a 1))
  21                    (cons 'a a))
  22                  (let* ((a 2))
  23                    (cons 'a a)))))))
  24
  25 (defmethod initialize-prototypes :after ((test test-plus))
  26   (with-test-slots (a b)
  27     (setf (prototypes test)
  28           (let* ((a 0) (b 0))
  29             (list
  30              (list (cons 'a a) (cons 'b b)))))))
  31
  32 (deftestsuite test-a ()
  33   ((a '(1 2))))
  34
  35 (deftestsuite test-a ()
  36   (a)
  37   (:cases (a '((1 2)))))
  38
  39 (addtest (test-a)
  40   (format t "~%~A" a))
  41
  42 (deftestsuite test-b (test-a)
  43   (b)
  44   (:cases (b '(4 5 6))))
  45
  46 (addtest (test-b)
  47   (format t "~%  ~A x ~A" a b))
  48
  49
  50 (deftestsuite test-e ()
  51   (a))
  52
  53 (defmethod initialize-prototypes :after ((test test-e))
  54   (setf (prototypes test)
  55         (list
  56          (list (cons 'a 1))
  57          (list (cons 'a 2)))))
  58
  59 (addtest (test-e)
  60   (format t "~%~A" a))
  61
  62 (deftestsuite test-f (test-e)
  63   (b))
  64
  65 (defmethod initialize-prototypes :after ((test test-f))
  66   (setf (prototypes test)
  67         (list
  68          (list (cons 'b 4))
  69          (list (cons 'b 5))
  70          (list (cons 'b 6)))))
  71
  72 (addtest (test-f)
  73   (format t "~%  ~A x ~A" a b))
  74
  75 1
  76   1 4
  77   1 5
  78   1 6
  79 2
  80   2 4
  81   2 5
  82   2 6
  83
  84
  85 (defgeneric setup (suite)
  86   (:documentation "Setup at the testsuite-level")
  87   (:method ((suite test-mixin))
  88            (values)))
  89
  90 (defgeneric testsuite-teardown (suite)
  91   (:documentation "Cleanup at the testsuite level.")
  92   (:method ((suite test-mixin))
  93            (values)))
  94
  95 (defgeneric testsuite-run (suite result)
  96   (:documentation "Run the cases in this suite and it's children."))
  97
  98 (defgeneric setup-test (test-case)
  99   (:documentation "Setup for a test-case. By default it does nothing."))
 100
 101 (defgeneric teardown-test (test-case)
 102   (:documentation "Tear-down a test-case. By default it does nothing.")
 103   (:method-combination progn :most-specific-first))
 104
 105 (defgeneric testsuite-methods (test-case)
 106   (:documentation "Returns a list of the test methods defined for test. I.e.,
 107 the methods that should be run to do the tests for this test."))
 108
 109 ;;;;;;;;;;;;;;;;;;
 110
 111 (deftestsuite setup-and-slots-hierarchy-parent ()
 112   ((slot-parent (progn (push :slot-parent *test-scratchpad*) :a)))
 113   :setup (push :setup-parent *test-scratchpad*)
 114   :teardown (push :teardown-parent *test-scratchpad*))
 115
 116 (deftestsuite setups-and-slots-hierarchy-child
 117     (setup-and-slots-hierarchy-parent)
 118   ((slot-child (progn (push :slot-child *test-scratchpad*) :a)))
 119   :setup (push :setup-child *test-scratchpad*)
 120   :teardown (push :teardown-child *test-scratchpad*))
 121
 122
 123
 124 ;;;;;;;;;;;;;;;;;;;;;
 125
 126
 127
 128 (defvar *dynamics-before-setup* :dbs)
 129
 130 (deftestsuite dynamics-before-setup ()
 131   ()
 132   :setup (setf *test-notepad* nil))
 133
 134 (deftestsuite dynamics-before-setup-helper ()
 135   ((slot (progn (push :slot *test-notepad*) :slot)))
 136   :dynamic-variables (*dynamics-before-setup*
 137                       (progn (push :dynamics *test-notepad*) :dynamics))
 138   :setup (push :setup *test-notepad*))
 139
 140 (addtest (dynamics-before-setup-helper)
 141   test-1
 142   (push :test *test-notepad*)
 143   (ensure-same *dynamics-before-setup* :dynamics))
 144
 145 (addtest (dynamics-before-setup)
 146   test-1
 147   (run-test :suite 'dynamics-before-setup-helper
 148             :name 'test-1)
 149   (ensure-same (reverse *test-notepad*)
 150                '(:dynamics :slot :setup :test)))
 151
 152 (run-test :break-on-errors? t)
 153
 154
 155
 156
 157
 158 (deftestsuite warnings-and-errors ()
 159   ())
 160
 161 (defun warnings-and-errors-function (mode)
 162   (ecase mode
 163     (:warn (warn "this is a warning all by itself"))
 164     (:error (error "this is an error all by itself"))
 165     (:warn-error (warn "first we warn") (error "then we error"))
 166     (:error-warn (error "first we error") (warn "then we warn"))))
 167
 168 (addtest (warnings-and-errors)
 169   warning-does-not-hide-error-1
 170   (ensure-error (warnings-and-errors-function :warn-error)))
 171
 172 (addtest (warnings-and-errors)
 173   warning-does-not-hide-error-2
 174   (ensure-warning (warnings-and-errors-function :warn-error)))
 175
 176