Commits

Meikel Brandmeyer committed 39a1d31

Re-implement (again) the harness as set of multimethods

  • Participants
  • Parent commits 1220b8e

Comments (0)

Files changed (3)

File src/de/kotka/clojurecheck.clj

      [clojure.contrib.def :only (defvar defvar-)])
   (:load
      "clojurecheck/directives"
+     "clojurecheck/infrastructure"
      "clojurecheck/harness"
-     "clojurecheck/infrastructure"
      "clojurecheck/tests"
      "clojurecheck/arbitrary"
      "clojurecheck/combinators"

File src/de/kotka/clojurecheck/harness.clj

 
 (clojure.core/in-ns 'de.kotka.clojurecheck)
 
-(gen-interface
-  :name    de.kotka.clojurecheck.IHarness
-  :methods [[plan [Integer] Object]
-            [diag [String] Object]
-            [bailOut [String] Object]
-            [reportResult [Object Boolean String] Object]
-            [getResult [] Object]
-            [getDiagnostics [] String]])
+(defn make-standard-harness
+  "Creates a new standard harness, which reports in TAP format to *out*."
+  []
+  (hash-map :type         ::Standard
+            :current-test (ref 0)))
 
-(import 'de.kotka.clojurecheck.IHarness)
+(defmethod plan ::Standard
+  [cnt]
+  (print "1..")
+  (print cnt)
+  (newline)
+  (flush))
 
-(defn make-standard-harness
-  "make-standard-harness creates a new standard harness."
-  []
-  (let [current-test (ref 1)]
-    (proxy [IHarness] []
-      (plan
-        [count]
-        (print "1..")
-        (print count)
-        (newline)
-        (flush))
+(defmethod diag ::Standard
+  [msg]
+  (doseq [l (.split msg "\n")]
+    (print "# ")
+    (print l)
+    (newline)
+    (flush)))
 
-      (diag
-        [msg]
-        (doseq [l (.split msg "\n")]
-          (print "# ")
-          (print l)
-          (newline)
-          (flush)))
+(defmethod bail-out ::Standard
+  ([]
+   (bail-out nil))
+  ([msg]
+   (print "Bail out!")
+   (when msg
+     (print " ")
+     (print msg))
+   (newline)
+   (flush)
+   (java.lang.System/exit 1)))
 
-      (bailOut
-        [msg]
-        (print "Bail out!")
-        (when msg
-          (print " ")
-          (print msg))
-        (newline)
-        (flush)
-        (.exit java.lang.System 1))
-
-      (reportResult
-        [m t desc]
-        (if t
-          (print "ok ")
-          (print "not ok "))
-        (print (dosync
-                 (let [c @current-test]
-                   (alter current-test inc)
-                   c)))
-        (cond
-          (= m :todo) (print " # TODO")
-          (= m :skip) (print " # SKIP"))
-        (when-not (nil? desc)
-          (print " - ")
-          (print desc))
-        (newline)
-        (flush)))))
+(defmethod report-result ::Standard
+  [m t desc]
+  (if t
+    (print "ok ")
+    (print "not ok "))
+  (print (dosync (commute (*the-harness* :current-test) inc)))
+  (condp = m
+    :todo (print " # TODO")
+    :skip (print " # SKIP")
+    nil)
+  (when desc
+    (print " - ")
+    (print desc))
+  (newline)
+  (flush))
 
 (defn make-batch-harness
   "Create a new batch harness suitable to run recursive tests. So one
   can specify tests, which themselves contain other tests."
   []
-  (let [our-plan     (ref :noplan)
-        current-test (ref 1)
-        failed-test  (ref false)
-        diagnostics  (ref "")]
-    (proxy [IHarness] []
-      (plan
-        [count]
-        (dosync (ref-set our-plan count)))
+  (hash-map :type         ::Batch
+            :our-plan     (ref :noplan)
+            :current-test (ref 1)
+            :failed-test  (ref false)
+            :diagnostics  (ref "")))
 
-      (diag
-        [msg]
-        (dosync (commute diagnostics #(str %1 \newline %2) msg)))
+(defmethod plan ::Batch
+  [cnt]
+  (dosync (ref-set (*the-harness* :our-plan) cnt)))
 
-      (bailOut
-        [msg]
-        (dosync (commute diagnostics #(str %1 "Bailing out!"
-                                           (when msg (str " " msg)))))
-        (throw (new FatalTestError)))
+(defmethod diag ::Batch
+  [msg]
+  (dosync (commute (*the-harness* :diagnostics) #(str %1 \newline %2) msg)))
 
-      (reportResult
-        [m t desc]
-        (when-not t
-          (dosync (ref-set failed-test true)))
-        (dosync (alter current-test inc)))
+(defmethod bail-out ::Batch
+  [msg]
+  (dosync (commute (*the-harness* :diagnostics)
+                   #(str %1 "Bailing out!" (when msg (str " " msg)))))
+  (throw (FatalTestError.)))
 
-      (getResult
-        []
-        (and (or (= @our-plan :noplan)
-                 (= @our-plan (dec @current-test)))
-             (not @failed-test)))
+(defmethod report-result ::Batch
+  [m t desc]
+  (when-not t
+    (dosync (ref-set (*the-harness* :failed-test) true)))
+  (dosync (commute (*the-harness* :current-test) inc)))
 
-      (getDiagnostics
-        []
-        @diagnostics))))
+(defmethod get-result ::Batch
+  []
+  (dosync
+    (and (or (= (deref (*the-harness* :our-plan)) :noplan)
+             (= (deref (*the-harness* :our-plan))
+                (deref (*the-harness* :current-test))))
+         (not (deref (*the-harness* :failed-test))))))
+
+(defmethod get-diagnostics ::Batch
+  []
+  (deref (*the-harness* :diagnostics)))
 
 (defvar *the-harness*
   (make-standard-harness)
-  "The handlers. This actually implements the TAP protocol itself, but may be
+  "The harness. This actually implements the TAP protocol itself, but may be
   re-bound via binding to enable different behaviour.")
 
 (defn with-harness*
+  "Bind the harness to the given one for the execution of thunk. Returns
+  the harness afterwards."
   [harness thunk]
   (binding [*the-harness* harness]
     (thunk)
     harness))
 
 (defmacro with-harness
+  "Binds the harness to the given one for the execution of the body.
+  Return the harness afterwards."
   [harness & body]
   `(with-harness* ~harness (fn [] ~@body)))

File src/de/kotka/clojurecheck/infrastructure.clj

 
 (clojure.core/in-ns 'de.kotka.clojurecheck)
 
-(defn plan
+(declare *the-harness*)
+
+(defn- harness-dispatch [& _] (*the-harness* :type))
+
+(defmulti
+  #^{:arglists '([cnt])
+     :doc
   "Print the test plan. Ie. the number of tests you intend to run. This gives
   the harness a chance to see, whether the tests ran completely. It is not
   strictly necessary to provide a plan. However it is strongly encouraged to
   Example:
 
   | => (plan 10)
-  | 1..10"
-  [count]
-  (. *the-harness* plan count))
+  | 1..10"}
+  plan
+  harness-dispatch)
 
-(defn diag
+(defmulti
+  #^{:arglists '([msg])
+     :doc
   "Print diagnostics. Sometimes a test script wants to provide diagnostic
   information to the user. Eg. <is?> and friends provide information about
   the deviation from the expected outcome to the user. <diag> is a utility
   Example:
 
   | => (diag „flogiston pressure dropping rapidly“)
-  | # flogiston pressure dropping rapidly"
-  [msg]
-  (. *the-harness* diag msg))
+  | # flogiston pressure dropping rapidly"}
+  diag
+  harness-dispatch)
 
-(defn bail-out
+(defmulti
+  #^{:arglists '([] [msg])
+     :doc
   "Bail out of the test process. Sometimes the system or the environment is so
   messed up, that further testing doesn't make sense. Then <bail-out> may be
   used to stop further testing immediately. Optionally a reason about the
   | => (bail-out)
   | Bail out!
   | => (bail-out „flogiston pressure too low“)
-  | Bail out! flogiston pressure too low"
-  ([]    (. *the-harness* bailOut nil))
-  ([msg] (. *the-harness* bailOut msg)))
+  | Bail out! flogiston pressure too low"}
+  bail-out
+  harness-dispatch)
 
-(defn- report-result
-  [m t d]
-  (. *the-harness* reportResult m t d))
+(defmulti
+  #^{:arglists '([m t d])
+     :doc
+  "Report the result of a test. This should actually never be called
+  directly. This is done by the test-driver utility."}
+  report-result
+  harness-dispatch)
+
+(defmulti
+  #^{:arglists '([])
+     :doc
+  "Retrieve the result of the tests run in the current harness. This
+  is not implemented for all harnesses."}
+  get-result
+  harness-dispatch)
+
+(defmulti
+  #^{:arglists '([])
+     :doc
+  "Retrieve the diagnostics of the tests run in the current harness.
+  This is not implemented for all harnesses."}
+  get-diagnostics
+  harness-dispatch)
 
 (defn test-driver
   "Driver function for the tests. This function should only be called, when