|
rlm@10
|
1 ; Copyright (c) Chris Houser, Jan 2009. All rights reserved.
|
|
rlm@10
|
2 ; The use and distribution terms for this software are covered by the
|
|
rlm@10
|
3 ; Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
|
|
rlm@10
|
4 ; which can be found in the file epl-v10.html at the root of this distribution.
|
|
rlm@10
|
5 ; By using this software in any fashion, you are agreeing to be bound by
|
|
rlm@10
|
6 ; the terms of this license.
|
|
rlm@10
|
7 ; You must not remove this notice, or any other, from this software.
|
|
rlm@10
|
8
|
|
rlm@10
|
9 ; == EXPERIMENTAL ==
|
|
rlm@10
|
10 ; System for defining and using custom errors
|
|
rlm@10
|
11 ; Please contact Chouser if you have any suggestions for better names
|
|
rlm@10
|
12 ; or API adjustments.
|
|
rlm@10
|
13
|
|
rlm@10
|
14 (ns
|
|
rlm@10
|
15 ^{:author "Chris Houser",
|
|
rlm@10
|
16 :doc "EXPERIMENTAL
|
|
rlm@10
|
17 System for defining and using custom errors
|
|
rlm@10
|
18 Please contact Chouser if you have any suggestions for better names
|
|
rlm@10
|
19 or API adjustments."}
|
|
rlm@10
|
20 clojure.contrib.error-kit
|
|
rlm@10
|
21 (:use [clojure.contrib.def :only (defvar defvar-)]
|
|
rlm@10
|
22 [clojure.stacktrace :only (root-cause)]))
|
|
rlm@10
|
23
|
|
rlm@10
|
24 (defn- make-ctrl-exception [msg data]
|
|
rlm@10
|
25 "Create an exception object with associated data, used for passing
|
|
rlm@10
|
26 control and data to a dynamically containing handler."
|
|
rlm@10
|
27 (proxy [Error clojure.lang.IDeref] [msg]
|
|
rlm@10
|
28 (toString [] (str "Error Kit Control Exception: " msg ", " (pr-str data)))
|
|
rlm@10
|
29 (deref [] data)))
|
|
rlm@10
|
30
|
|
rlm@10
|
31 (defvar- ctrl-exception-class
|
|
rlm@10
|
32 (class (make-ctrl-exception nil nil)))
|
|
rlm@10
|
33
|
|
rlm@10
|
34 (defvar- *handler-stack* () "Stack of bound handler symbols")
|
|
rlm@10
|
35
|
|
rlm@10
|
36 (defvar- *continues* {} "Map of currently available continue forms")
|
|
rlm@10
|
37
|
|
rlm@10
|
38
|
|
rlm@10
|
39 (defmacro throw-msg
|
|
rlm@10
|
40 "Returns a function that throws a Java Exception with the given
|
|
rlm@10
|
41 name. Useful to associate a new error-kit error type with a
|
|
rlm@10
|
42 particular Java Exception class, via the :unhandled error key."
|
|
rlm@10
|
43 [class-name]
|
|
rlm@10
|
44 `(fn [x#] (throw (new ~class-name (:msg x#)))))
|
|
rlm@10
|
45
|
|
rlm@10
|
46 (defn error
|
|
rlm@10
|
47 "Base type for all error-kit errors"
|
|
rlm@10
|
48 {::args [:msg :unhandled :tag]}
|
|
rlm@10
|
49 [details]
|
|
rlm@10
|
50 (merge {:tag `error :msg "exception via error-kit"
|
|
rlm@10
|
51 :unhandled (throw-msg Exception)}
|
|
rlm@10
|
52 details))
|
|
rlm@10
|
53
|
|
rlm@10
|
54 (defn- qualify-sym [sym]
|
|
rlm@10
|
55 (let [v (resolve sym)]
|
|
rlm@10
|
56 (assert v)
|
|
rlm@10
|
57 (apply symbol (map #(str (% (meta v))) [:ns :name]))))
|
|
rlm@10
|
58
|
|
rlm@10
|
59 (defmacro deferror
|
|
rlm@10
|
60 "Define a new error type"
|
|
rlm@10
|
61 {:arglists '([name [parent-error?] doc-string? [args*] & body]
|
|
rlm@10
|
62 [name [parent-error?] doc-string? args-destruct-map & body])}
|
|
rlm@10
|
63 [err-name pvec & decl]
|
|
rlm@10
|
64 (let [pvec (if (empty? pvec) [`error] pvec)
|
|
rlm@10
|
65 [docstr args & body] (if (string? (first decl)) decl (cons nil decl))
|
|
rlm@10
|
66 args (or args [])
|
|
rlm@10
|
67 argmap (if (vector? args) `{:keys ~args} args)
|
|
rlm@10
|
68 body (or body {})
|
|
rlm@10
|
69 qual-err-name (symbol (str *ns*) (name err-name))]
|
|
rlm@10
|
70 (assert (== (count pvec) 1)) ; only support single-inheritance for now
|
|
rlm@10
|
71 (assert (vector? args)) ; only vector (keyword destruct) args for now
|
|
rlm@10
|
72 `(do
|
|
rlm@10
|
73 (defn ~err-name [details#]
|
|
rlm@10
|
74 (let [basedata# ((resolve (first (parents '~qual-err-name))) details#)
|
|
rlm@10
|
75 ~argmap basedata#]
|
|
rlm@10
|
76 (merge basedata# {:tag '~qual-err-name} (do ~@body) details#)))
|
|
rlm@10
|
77 (alter-meta! (var ~err-name) assoc
|
|
rlm@10
|
78 :doc ~docstr ::args ~(vec (map #(keyword (str %)) args)))
|
|
rlm@10
|
79 ~@(for [parent pvec]
|
|
rlm@10
|
80 `(derive '~qual-err-name '~(qualify-sym parent)))
|
|
rlm@10
|
81 (var ~err-name))))
|
|
rlm@10
|
82
|
|
rlm@10
|
83 (defn- throw-to [msg target-map args]
|
|
rlm@10
|
84 (throw (make-ctrl-exception msg (assoc target-map :args args))))
|
|
rlm@10
|
85
|
|
rlm@10
|
86 (defn raise*
|
|
rlm@10
|
87 "Raise the given error object, best if created by an error
|
|
rlm@10
|
88 constructor defined with deferror. See also 'raise' macro."
|
|
rlm@10
|
89 [err]
|
|
rlm@10
|
90 (let [err-tag (:tag err)]
|
|
rlm@10
|
91 (loop [hs *handler-stack*]
|
|
rlm@10
|
92 (if (empty? hs)
|
|
rlm@10
|
93 ((:unhandled err) err)
|
|
rlm@10
|
94 (let [[{:keys [htag] :as handler}] hs]
|
|
rlm@10
|
95 (if (and htag (not (isa? err-tag htag)))
|
|
rlm@10
|
96 (recur (next hs))
|
|
rlm@10
|
97 (let [rtn ((:hfunc handler) err)]
|
|
rlm@10
|
98 (if-not (vector? rtn)
|
|
rlm@10
|
99 (throw-to "default" handler (list rtn))
|
|
rlm@10
|
100 (condp = (rtn 0)
|
|
rlm@10
|
101 ::continue-with (rtn 1)
|
|
rlm@10
|
102 ::continue (if-let [continue (*continues* (rtn 1))]
|
|
rlm@10
|
103 (throw-to "continue" continue (rtn 2))
|
|
rlm@10
|
104 (do (prn *continues*) (throw
|
|
rlm@10
|
105 (Exception.
|
|
rlm@10
|
106 (str "Unbound continue name " (rtn 1))))))
|
|
rlm@10
|
107 ::do-not-handle (recur (next hs))
|
|
rlm@10
|
108 (throw-to "do-not-handle" handler (list rtn)))))))))))
|
|
rlm@10
|
109
|
|
rlm@10
|
110 (defmacro raise
|
|
rlm@10
|
111 "Raise an error of the type err-name, constructed with the given args"
|
|
rlm@10
|
112 [err-name & args]
|
|
rlm@10
|
113 `(raise* (~err-name ~(zipmap (::args (meta (resolve err-name)))
|
|
rlm@10
|
114 args))))
|
|
rlm@10
|
115
|
|
rlm@10
|
116 ; It'd be nice to assert that these are used in a tail position of a handler
|
|
rlm@10
|
117 (defmacro do-not-handle
|
|
rlm@10
|
118 "Use in a tail position of a 'handle' form to indicate 'raise' should
|
|
rlm@10
|
119 not consider the error handled, but should continue searching for an
|
|
rlm@10
|
120 appropriate 'handle' form. Allows finer-grain control over catching
|
|
rlm@10
|
121 than just the error type."
|
|
rlm@10
|
122 []
|
|
rlm@10
|
123 `[::do-not-handle])
|
|
rlm@10
|
124
|
|
rlm@10
|
125 (defmacro continue-with [value]
|
|
rlm@10
|
126 "Use in a tail position of a 'handle' form to cause the currently
|
|
rlm@10
|
127 running 'raise' to return the given 'value'."
|
|
rlm@10
|
128 `[::continue-with ~value])
|
|
rlm@10
|
129
|
|
rlm@10
|
130 (defmacro continue [continue-name & args]
|
|
rlm@10
|
131 "Use in a tail position of a 'handle' form to pass control to the
|
|
rlm@10
|
132 named 'continue' form, passing in the given args. The 'continue'
|
|
rlm@10
|
133 form with the given name and the smallest dynamic scope surrounding
|
|
rlm@10
|
134 the currently running 'raise' will be used."
|
|
rlm@10
|
135 `[::continue '~continue-name [~@args]])
|
|
rlm@10
|
136
|
|
rlm@10
|
137
|
|
rlm@10
|
138 (def ^{:doc "Special form to be used inside a 'with-handler'. When
|
|
rlm@10
|
139 any error is 'raised' from withing the dynamic scope of 'body' that
|
|
rlm@10
|
140 is of error-name's type or a derived type, the args will be bound
|
|
rlm@10
|
141 and the body executed. If no 'error-name' is given, the body will
|
|
rlm@10
|
142 be executed for regardless of the type of error raised. The body
|
|
rlm@10
|
143 may return a value, in which case that will be the return value of
|
|
rlm@10
|
144 the entire 'with-handler' form, or it may use any of the special
|
|
rlm@10
|
145 return forms, 'do-not-handle', 'continue-with', or 'continue'."
|
|
rlm@10
|
146 :arglists '([error-name? [args*] & body]
|
|
rlm@10
|
147 [error-name? args-destruct-map-args & body])}
|
|
rlm@10
|
148 handle)
|
|
rlm@10
|
149
|
|
rlm@10
|
150 (def ^{:doc "Special form to be used inside a 'with-handler'.
|
|
rlm@10
|
151 Control can be passed to this 'continue' form from a 'raise' enclosed
|
|
rlm@10
|
152 in this with-handler's dynamic scope, when this 'continue-name' is
|
|
rlm@10
|
153 given to a 'continue' form."
|
|
rlm@10
|
154 :arglists '([continue-name [args*] & body])}
|
|
rlm@10
|
155 bind-continue)
|
|
rlm@10
|
156
|
|
rlm@10
|
157 (defn- special-form [form]
|
|
rlm@10
|
158 (and (list form)
|
|
rlm@10
|
159 (symbol? (first form))
|
|
rlm@10
|
160 (#{#'handle #'bind-continue} (resolve (first form)))))
|
|
rlm@10
|
161
|
|
rlm@10
|
162
|
|
rlm@10
|
163 (defmacro with-handler
|
|
rlm@10
|
164 "This is error-kit's dynamic scope form. The body will be executed
|
|
rlm@10
|
165 in a dynamic context that includes all of the following 'handle' and
|
|
rlm@10
|
166 'bind-continue' forms."
|
|
rlm@10
|
167 [& forms]
|
|
rlm@10
|
168 (let [[body special-forms] (split-with (complement special-form) forms)]
|
|
rlm@10
|
169 (assert (every? special-form special-forms))
|
|
rlm@10
|
170 (let [blockid (gensym)
|
|
rlm@10
|
171 handlers (for [[type & more] special-forms
|
|
rlm@10
|
172 :when (= (resolve type) #'handle)]
|
|
rlm@10
|
173 (let [[htag args & hbody] (if (symbol? (first more))
|
|
rlm@10
|
174 more
|
|
rlm@10
|
175 (cons nil more))
|
|
rlm@10
|
176 argmap (if (vector? args) `{:keys ~args} args)]
|
|
rlm@10
|
177 `{:blockid '~blockid
|
|
rlm@10
|
178 :htag ~(when htag (list `quote (qualify-sym htag)))
|
|
rlm@10
|
179 :hfunc (fn [~argmap] ~@hbody)
|
|
rlm@10
|
180 :rfunc identity}))
|
|
rlm@10
|
181 continues (into {}
|
|
rlm@10
|
182 (for [[type & more] special-forms
|
|
rlm@10
|
183 :when (= (resolve type) #'bind-continue)]
|
|
rlm@10
|
184 [(list `quote (first more))
|
|
rlm@10
|
185 `{:blockid '~blockid
|
|
rlm@10
|
186 :rfunc (fn ~@(next more))}]))]
|
|
rlm@10
|
187 `(try
|
|
rlm@10
|
188 (binding [*handler-stack* (list* ~@handlers @#'*handler-stack*)
|
|
rlm@10
|
189 *continues* (merge @#'*continues* ~@continues)]
|
|
rlm@10
|
190 ~@body)
|
|
rlm@10
|
191 (catch Throwable e#
|
|
rlm@10
|
192 (let [root-cause# (root-cause e#)]
|
|
rlm@10
|
193 (if-not (instance? @#'ctrl-exception-class root-cause#)
|
|
rlm@10
|
194 (throw e#)
|
|
rlm@10
|
195 (let [data# @root-cause#]
|
|
rlm@10
|
196 (if (= '~blockid (:blockid data#))
|
|
rlm@10
|
197 (apply (:rfunc data#) (:args data#))
|
|
rlm@10
|
198 (throw e#))))))))))
|
|
rlm@10
|
199
|
|
rlm@10
|
200 (defn rebind-fn [func]
|
|
rlm@10
|
201 (let [a *handler-stack*, b *continues*]
|
|
rlm@10
|
202 (fn [& args]
|
|
rlm@10
|
203 (binding [*handler-stack* a
|
|
rlm@10
|
204 *continues* b]
|
|
rlm@10
|
205 (apply func args)))))
|
|
rlm@10
|
206
|
|
rlm@10
|
207 (comment
|
|
rlm@10
|
208
|
|
rlm@10
|
209 (alias 'kit 'clojure.contrib.error-kit)
|
|
rlm@10
|
210
|
|
rlm@10
|
211 ; This defines an error and its action if unhandled. A good choice of
|
|
rlm@10
|
212 ; unhandled. action is to throw a Java exception so users of your code
|
|
rlm@10
|
213 ; who do not want to use error-kit can still use normal Java try/catch
|
|
rlm@10
|
214 ; forms to handle the error.
|
|
rlm@10
|
215 (kit/deferror number-error [] [n]
|
|
rlm@10
|
216 {:msg (str "Number error: " n)
|
|
rlm@10
|
217 :unhandled (kit/throw-msg NumberFormatException)})
|
|
rlm@10
|
218
|
|
rlm@10
|
219 (kit/deferror odd-number-error [number-error]
|
|
rlm@10
|
220 "Indicates an odd number was given to an operation that is only
|
|
rlm@10
|
221 defined for even numbers."
|
|
rlm@10
|
222 [n]
|
|
rlm@10
|
223 {:msg (str "Can't handle odd number: " n)})
|
|
rlm@10
|
224
|
|
rlm@10
|
225 ; Raise an error by name with any extra args defined by the deferror
|
|
rlm@10
|
226 (defn int-half [i]
|
|
rlm@10
|
227 (if (even? i)
|
|
rlm@10
|
228 (quot i 2)
|
|
rlm@10
|
229 (kit/raise odd-number-error i)))
|
|
rlm@10
|
230
|
|
rlm@10
|
231 ; Throws Java NumberFormatException because there's no 'handle' form
|
|
rlm@10
|
232 (vec (map int-half [2 4 5 8]))
|
|
rlm@10
|
233
|
|
rlm@10
|
234 ; Throws Java Exception with details provided by 'raise'
|
|
rlm@10
|
235 (kit/with-handler
|
|
rlm@10
|
236 (vec (map int-half [2 4 5 8]))
|
|
rlm@10
|
237 (kit/handle odd-number-error [n]
|
|
rlm@10
|
238 (throw (Exception. (format "Odd number %d in vector." n)))))
|
|
rlm@10
|
239
|
|
rlm@10
|
240 ; The above is equivalent to the more complicated version below:
|
|
rlm@10
|
241 (kit/with-handler
|
|
rlm@10
|
242 (vec (map int-half [2 4 5 8]))
|
|
rlm@10
|
243 (kit/handle {:keys [n tag]}
|
|
rlm@10
|
244 (if (isa? tag `odd-number-error)
|
|
rlm@10
|
245 (throw (Exception. (format "Odd number %d in vector." n)))
|
|
rlm@10
|
246 (kit/do-not-handle))))
|
|
rlm@10
|
247
|
|
rlm@10
|
248 ; Returns "invalid" string instead of a vector when an error is encountered
|
|
rlm@10
|
249 (kit/with-handler
|
|
rlm@10
|
250 (vec (map int-half [2 4 5 8]))
|
|
rlm@10
|
251 (kit/handle kit/error [n]
|
|
rlm@10
|
252 "invalid"))
|
|
rlm@10
|
253
|
|
rlm@10
|
254 ; Inserts a zero into the returned vector where there was an error, in
|
|
rlm@10
|
255 ; this case [1 2 0 4]
|
|
rlm@10
|
256 (kit/with-handler
|
|
rlm@10
|
257 (vec (map int-half [2 4 5 8]))
|
|
rlm@10
|
258 (kit/handle number-error [n]
|
|
rlm@10
|
259 (kit/continue-with 0)))
|
|
rlm@10
|
260
|
|
rlm@10
|
261 ; Intermediate continue: [1 2 :oops 5 4]
|
|
rlm@10
|
262 (defn int-half-vec [s]
|
|
rlm@10
|
263 (reduce (fn [v i]
|
|
rlm@10
|
264 (kit/with-handler
|
|
rlm@10
|
265 (conj v (int-half i))
|
|
rlm@10
|
266 (kit/bind-continue instead-of-half [& instead-seq]
|
|
rlm@10
|
267 (apply conj v instead-seq))))
|
|
rlm@10
|
268 [] s))
|
|
rlm@10
|
269
|
|
rlm@10
|
270 (kit/with-handler
|
|
rlm@10
|
271 (int-half-vec [2 4 5 8])
|
|
rlm@10
|
272 (kit/handle number-error [n]
|
|
rlm@10
|
273 (kit/continue instead-of-half :oops n)))
|
|
rlm@10
|
274
|
|
rlm@10
|
275 ; Notes:
|
|
rlm@10
|
276
|
|
rlm@10
|
277 ; It seems likely you'd want to convert a handle clause to
|
|
rlm@10
|
278 ; bind-continue, since it would allow higher forms to request what you
|
|
rlm@10
|
279 ; used to do by default. Thus both should appear in the same
|
|
rlm@10
|
280 ; with-handler form
|
|
rlm@10
|
281
|
|
rlm@10
|
282 ; Should continue-names be namespace qualified, and therefore require
|
|
rlm@10
|
283 ; pre-definition in some namespace?
|
|
rlm@10
|
284 ; (kit/defcontinue skip-thing "docstring")
|
|
rlm@10
|
285
|
|
rlm@10
|
286 ; Could add 'catch' for Java Exceptions and 'finally' support to
|
|
rlm@10
|
287 ; with-handler forms.
|
|
rlm@10
|
288
|
|
rlm@10
|
289 )
|
