[Issue #82] formulas can have multiple bindings that each can be shru…

…nken

src/midje/ideas/formulas.clj

@@ -1,7 +1,8 @@
 (ns ^{:doc "Midje's special blend of generative-style testing."}
   midje.ideas.formulas
   (:use [midje.util.form-utils :only [named? pop-docstring]]
-        [midje.error-handling.validation-errors :only [simple-report-validation-error validate when-valid]]
+        [midje.error-handling.validation-errors :only [simple-report-validation-error 
+                                                       validate when-valid]]
         [midje.ideas.prerequisites :only [is-head-of-form-providing-prerequisites?]]
         [midje.ideas.arrows :only [leaves-contain-arrow? 
                                    leaf-expect-arrows]]))
@@ -23,12 +24,13 @@
   `(midje.sweet/fact ~docstring   
      ~@body :formula :formula-in-progress))
 
-(defmacro shrink-failure-case [docstring binding-name failed-binding-val body]
-  `(loop [[cur-shrunk# & rest#] (midje.ideas.formulas/shrink ~failed-binding-val)]
-     (when cur-shrunk#
-       (when (let [~binding-name cur-shrunk#]
-               ~(formula-fact docstring body))
-         (recur rest#)))))
+(defmacro shrink-failure-case [docstring binding-names failed-binding-vals body]
+  `(loop [shrunk-vectors# (map midje.ideas.formulas/shrink ~failed-binding-vals)]
+     (let [cur-shrunks# (map first shrunk-vectors#)]
+       (when (and (first cur-shrunks#)
+                  (let [~binding-names cur-shrunks#]
+                    ~(formula-fact docstring body)))
+           (recur (map rest shrunk-vectors#))))))
 
 (defmacro formula 
   "ALPHA/EXPERIMENTAL - Generative-style fact macro. 
@@ -47,16 +49,20 @@
     (let [[docstring? [bindings & body]] (pop-docstring args)
           fact (formula-fact docstring? body)
           conclusion-signal `(midje.sweet/fact
-                               :always-pass midje.sweet/=> :always-pass :formula :formula-conclude )]
+                               :always-pass midje.sweet/=> :always-pass 
+                               :formula :formula-conclude )]
 
       `(try
          (loop [cnt-down# midje.ideas.formulas/*num-generations-per-formula*]
            (when (pos? cnt-down#)
-             (let [snd-binding# ~(second bindings)
-                   ~(first bindings) snd-binding#]
+             (let [snd-bindings# ~(vec (take-nth 2 (rest bindings)))
+                   ~(vec (take-nth 2 bindings)) snd-bindings#]
                (if ~fact
                  (recur (dec cnt-down#))
-                 (shrink-failure-case ~docstring? ~(first bindings) snd-binding# ~body)))))
+                 (shrink-failure-case ~docstring? 
+                                      ~(vec (take-nth 2 bindings)) 
+                                      snd-bindings# 
+                                      ~body)))))
          (finally
            ~conclusion-signal)))))
 

src/midje/util/ecosystem.clj

@@ -14,6 +14,10 @@
        (= 2 (:minor *clojure-version*))
        (= 0 (:incremental *clojure-version*))))
 
+(defmacro when-1-3+ [& body] 
+  (when-not (= 2 (:minor *clojure-version*))
+    `(do ~@body)))
+
 (defmacro unless-1-2-0
   "Skip body completely - including 'Unable to resolve classname' errors."
   [& body]

test/midje/ideas/t_formulas.clj

@@ -2,7 +2,8 @@
 
 (ns midje.ideas.t-formulas
   (:use midje.test-util
-        midje.sweet))
+        midje.sweet
+        midje.util.ecosystem))
 
 ;;;; Validation
 
@@ -38,11 +39,15 @@
 (defn- gen-int [pred]
   (rand-nth (filter pred [-5 -4 -3 -2 -1 0 1 2 3 4 5])))
 
-(formula [n (gen-int #(< % 1))]
+(formula
+  "allows users to dynamically rebind to 1+"
+  [n (gen-int #(< % 1))]
   (binding [midje.ideas.formulas/*num-generations-per-formula* n] nil) 
      => (throws #"must be an integer 1 or greater"))
 
-(formula [n (gen-int #(>= % 1))]
+(formula
+  "binding too smalla value - gives nice error msg"
+  [n (gen-int #(>= % 1))]
   (binding [midje.ideas.formulas/*num-generations-per-formula* n] nil) 
      =not=> (throws Exception))
 
@@ -52,13 +57,9 @@
 ;; the first formula use ever!
 (defn make-string []
   (rand-nth ["a" "b" "c" "d" "e" "f" "g" "i"]))
-;(formula "can now use simple generative-style formulas"  ;; COMMENTED OUT TO TEMPORARILY DISALLOW > 1 bindings
-;  [a (make-string) b (make-string)]
-;  (str a b) => (has-prefix a))
-
-(formula "can now use simple generative-style formulas"
-  [a (make-string)]
-  (str a) => (has-prefix a))
+(formula "can now use simple generative-style formulas - with multipel bindings"
+  [a (make-string) b (make-string) c (make-string)]
+  (str a b c) => (has-prefix (str a b)))
 
 (unfinished f)
 (defn g [x] (str (f x) x))
@@ -99,20 +100,22 @@
 (fact "calls generator once" @z-maker-count => 1)
 (fact "evalautes body once" @my-identity-count => 1)
 
+
 ;; shrinks failure case to smallest possible failure
-(with-redefs [midje.ideas.formulas/shrink (constantly [0 1 2 3 4 5])] ;; I don't think wtih-redefs is working right, hence the failures I'm seeing
-  (after-silently
-    (formula [x 100] 
-      x => neg?)))
-(fact @reported => (one-of (contains {:type :mock-expected-result-functional-failure
-                                      :actual 0})))
-
-
-
-;;; ... shrunken failure case is in the same domain as the generator 
-;;;     used to create the input case in the forst place.
-;(after-silently
-;  (formula [x (guard (gs/int) odd?)] 
-;    x => neg?))
-;(fact @reported => (one-of (contains {:type :mock-expected-result-failure
-;                                      :actual 1})))
+(when-1-3+
+  (with-redefs [midje.ideas.formulas/shrink (constantly [0 1 2 3 4 5])]
+    (after-silently
+      (formula [x 100] 
+        x => neg?)))
+  (fact @reported => (one-of (contains {:type :mock-expected-result-functional-failure
+                                        :actual 0}))))
+
+
+;; shrunken failure case is in the same domain as the generator 
+;; used to create the input case in the forst place.
+(after-silently
+  (formula [x (gen-int odd?)]  ;;(guard (gs/int) odd?)] 
+    x => neg?))
+(future-fact "shrunken failure case is in the same domain as the generator" 
+  @reported => (one-of (contains {:type :mock-expected-result-failure
+                                  :actual 1})))