Permalink
Browse files

added a-catch

  • Loading branch information...
joegallo committed May 18, 2011
1 parent e9804cc commit f44f698298a214f50f52fe6cefaad24ff844cf70
Showing with 117 additions and 1 deletion.
  1. +50 −1 src/conduit/core.clj
  2. +67 −0 test/conduit/test_core.clj
View
@@ -1,7 +1,8 @@
(ns conduit.core
(:use [clojure.contrib.seq-utils :only [indexed]]
+ [clojure.contrib.def :only [defmacro-]]
[clojure.pprint :only [pprint]]
- arrows.core))
+ [arrows.core]))
(def *testing-conduit* false)
@@ -387,6 +388,52 @@
:created-by :a-except
:args [p catch-p]}))
+(defmacro- dynamic-try-catch [[class e] try-block catch-block]
+ `(try
+ ~try-block
+ (catch Throwable ~e
+ (if (instance? ~class ~e)
+ ~catch-block
+ (throw ~e)))))
+
+(defn a-catch
+ ([p catch-p]
+ (a-catch Exception p catch-p))
+ ([class p catch-p]
+ (letfn [(a-catch [f catch-f x]
+ (dynamic-try-catch
+ [class e]
+ (let [[new-x new-f] (f x)]
+ [new-x (partial a-catch new-f catch-f)])
+ (let [[new-x new-catch] (catch-f [e x])]
+ [new-x (partial a-catch f new-catch)])))
+ (a-catch-sg [f catch-f x]
+ (dynamic-try-catch
+ [class e]
+ (let [result-f (f x)]
+ (fn []
+ (dynamic-try-catch
+ [class e]
+ (let [[new-x new-f] (result-f)]
+ [new-x (partial a-catch-sg new-f catch-f)])
+ (let [[new-x new-catch] (catch-f [e x])]
+ [new-x (partial a-catch-sg f new-catch)]))))
+ (fn []
+ (let [[new-x new-catch] (catch-f [e x])]
+ [new-x (partial a-catch-sg f new-catch)]))))]
+ {:parts (:parts p)
+ :reply (partial a-catch
+ (:reply p)
+ (:reply catch-p))
+ :no-reply (partial a-catch
+ (:no-reply p)
+ (:no-reply catch-p))
+ :scatter-gather (partial a-catch-sg
+ (:scatter-gather p)
+ (:reply catch-p))
+ :created-by :a-catch
+ :args [class p catch-p]})))
+
(defn a-finally [p final-p]
(letfn [(a-finally [f final-f x]
(try
@@ -483,6 +530,8 @@
(a-loop (test-conduit bp)
iv)))
:a-except (apply a-except (map test-conduit (:args p)))
+ :a-catch (apply a-catch (first (:args p))
+ (map test-conduit (rest (:args p))))
:a-finally (apply a-finally (map test-conduit (:args p)))
:disperse (disperse (test-conduit (:args p))))))
View
@@ -454,6 +454,73 @@
pass-through)
(range 5))))))
+(deftest test-a-catch
+ (let [te (a-arr (fn [x]
+ (when (even? x)
+ (throw (Exception. "An even int")))
+ (* 2 x)))
+ x (assoc te
+ :no-reply (fn this-fn [_]
+ [[2] this-fn])
+ :reply (fn this-fn [_]
+ [[1] this-fn])
+ :scatter-gather (fn this-fn [x]
+ (if (zero? (mod x 3))
+ (throw (Exception. "Div by 3"))
+ (fn []
+ [[3] this-fn]))))
+ tx (a-catch x pass-through)
+ ty (a-catch te
+ (a-arr (fn [[e _]]
+ 10)))
+ tz (a-catch x
+ (a-arr (fn [[e _]]
+ 15)))]
+ (is (thrown? Exception
+ (conduit-map te (range 5))))
+
+ (is (= [nil 2 nil 6 nil]
+ (conduit-map (a-catch te
+ (a-arr (constantly nil)))
+ (range 5))))
+ (is (= (repeat 5 2)
+ (conduit-map tx
+ (range 5))))
+
+ (is (= [[10 15] [2 3] [10 3] [6 15] [10 3]]
+ (conduit-map (a-comp (a-all ty tz)
+ pass-through)
+ (range 5)))))
+ (let [e1 (a-arr (fn [x] (throw (ArithmeticException.))))
+ e2 (a-arr (fn [x] (throw (OutOfMemoryError.))))
+ t (a-arr (constantly true))]
+ (is (thrown? ArithmeticException
+ (conduit-map
+ (a-catch OutOfMemoryError
+ e1
+ t)
+ [1])))
+ (is (first (conduit-map
+ (a-catch ArithmeticException
+ e1
+ t)
+ [1])))
+ (is (first (conduit-map
+ (a-catch OutOfMemoryError
+ e2
+ t)
+ [1])))
+ (is (first (conduit-map
+ (a-catch Throwable
+ e1
+ t)
+ [1])))
+ (is (first (conduit-map
+ (a-catch Throwable
+ e2
+ t)
+ [1])))))
+
(deftest test-a-finally
(let [main-count (atom 0)
secondary-count (atom 0)

0 comments on commit f44f698

Please sign in to comment.