+;;; lazytest.clj
+
+;; by Stuart Sierra, http://stuartsierra.com/
+
+;; Copyright (c) 2010 Stuart Sierra. All rights reserved.  The use and
+;; distribution terms for this software are covered by the Eclipse
+;; Public License 1.0, which can be found at
+;; http://opensource.org/licenses/eclipse-1.0.php
+;;
+;; By using this software in any fashion, you are agreeing to be bound
+;; by the terms of this license.  You must not remove this notice, or
+;; any other, from this software.
+
+
+;;; PROTOCOLS
+
+(defprotocol TestSuccess
+  (success? [r] "Returns true if r is a 100% successful result."))
+
+(defprotocol Testable
+  (run-tests [x] "Runs tests defined for the Namespace, Var, or TestCase."))
+
+
+;;; DATATYPES
+
 (deftype Context [parents before after])
+
+(deftype TestCase [contexts children])
+
+(deftype Assertion [locals form])
+
+(deftype TestResult [source children]
+  TestSuccess (success? [] (every? success? children)))
+ 
+(deftype TestThrown [source error]
+  TestSuccess (success? [] false))
+ 
+(deftype AssertionPassed [source]
+  TestSuccess (success? [] true))
+ 
+(deftype AssertionFailed [source]
+  TestSuccess (success? [] false))
+ 
+(deftype AssertionThrown [source error]
+  TestSuccess (success? [] false))
+
+
+;;; ASSERTION HANDLING
+
+(defn- format-assertion [a]
+  {:pre [(= ::Assertion (type a))
+         (vector? (:locals a))]}
+  (let [form (:form a)]
+    `(fn ~(:locals a)
+       (try (if ~form
+              (AssertionPassed '~form)
+              (AssertionFailed '~form))
+            (catch Throwable t#
+              (AssertionThrown '~form t#))))))
+ 
+(defn compile-assertion [a]
+  (eval (format-assertion a)))
+ 
+(defmacro assertion [locals & body]
+  (format-assertion (Assertion locals `(do ~@body))))
+
+
+;;; CONTEXT HANDLING
 
 (defn open-context
   "Opens context c, and all its parents, unless it is already active."

(assert (= {c2 2, c3 3} (open-context {} c3)))
(assert (= {} (close-context {c2 2, c3 3} c3)))

(deftype TestCase [contexts children])


    (let [active (reduce close-context active (:parents c))]
      (dissoc active c))))


;;; TEST CASE HANDLING

(defn- unchunked-map
  "Like map but does not chunk results; slower but lazier than map."
  [f coll]
  (lazy-seq
   (when (seq coll)
     (cons (f (first coll))
           (unchunked-map f (next coll))))))

(defn- has-after?
  "True if Context c or any of its parents has an :after function."
  [c]
  (or (:after c)
      (some has-after? (:parents c))))

(defn run-test-case
  "Executes a test case in context."
  ([t] (run-test-case t {}))
  ([t active]
     {:pre [(= ::TestCase (type t))
            (every? #(= ::Context (type %)) (:contexts t))]}
     (try
      (let [merged (reduce open-context active (:contexts t))
            states (map merged (:contexts t))
            ;; Prevent chunking for truly lazy execution:
            results (unchunked-map (fn [c] (if (fn? c)
                                             (apply c states)
                                             (run-test-case c merged)))
                                   (:children t))]
        ;; Force non-lazy execution to handle shutdown properly:
        (when (some has-after? (:contexts t))
          (dorun results)
          (dorun (reduce close-context merged
                         ;; Only close contexts that weren't active at start:
                         (filter #(not (contains? active %))
                                 (reverse (:contexts t))))))
        (TestResult t results))
      (catch Throwable e (TestThrown t e)))))
 

;;; TEST RESULT HANDLING

(defn result-seq
  "Given a single TestResult, returns a depth-first sequence of that
  TestResult and all its children."
  [r]
  (tree-seq :children :children r))


;;; TESTABLE IMPLEMENTATIONS

(defn var-test-case
  "Creates a TestCase for a Var, using clojure.core/test."
  [v]
   #^{:name (:name (meta v))}
   (TestCase [] [(assertion [] (clojure.core/test v))]))
 
(defn test-var
  "Creates and runs a TestCase for the Var."
  [v]
  (run-test-case (var-test-case v)))
 
(defn ns-test-case
  "Creates a TestCase for the namespace that tests all its Vars."
  [n]
  #^{:name (ns-name n)}
  (TestCase [] (map var-test-case (ns-interns n))))
 
(defn test-ns
  "Creates and runs a TestCase for the namespace."
  [n]
  (run-test-case (ns-test-case n)))
 
(extend ::TestCase Testable {:run-tests run-test-case})
(extend clojure.lang.Var Testable {:run-tests test-var})
(extend clojure.lang.Namespace Testable {:run-tests test-ns})



;;; SELF-TESTS

;; Assertions
(def a1 (assertion [a] (pos? a)))

(assert (= ::AssertionPassed (type (a1 1))))
(assert (= ::AssertionFailed (type (a1 -1))))
(assert (= ::AssertionThrown (type (a1 "string"))))

;; Contexts
(def c1 (Context nil nil nil))

(assert (= {} (open-context {} c1)))
