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