Mercurial > lasercutter

comparison src/clojure/contrib/condition.clj @ 10:ef7dbbd6452c

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
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) Stephen C. Gilardi. All rights reserved. The use and
2 ;; distribution terms for this software are covered by the Eclipse Public
3 ;; License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
4 ;; be found in the file epl-v10.html at the root of this distribution. By
5 ;; using this software in any fashion, you are agreeing to be bound by the
6 ;; terms of this license. You must not remove this notice, or any other,
7 ;; from this software.
8 ;;
9 ;; condition.clj
10 ;;
11 ;; scgilardi (gmail)
12 ;; Created 09 June 2009
13
14 (ns ^{:author "Stephen C. Gilardi"
15 :doc "Flexible raising and handling of conditions:
16
17 Functions:
18
19 raise: raises a condition
20 handler-case: dispatches raised conditions to appropriate handlers
21 print-stack-trace: prints abbreviated or full condition stack traces
22
23 Data:
24
25 A condition is a map containing values for these keys:
26
27 - :type, a condition type specifier, typically a keyword
28 - :stack-trace, a stack trace to the site of the raise
29 - :message, a human-readable message (optional)
30 - :cause, a wrapped exception or condition (optional)
31 - other keys given as arguments to raise (optional)
32
33 Note: requires AOT compilation.
34
35 Based on an idea from Chouser:
36 http://groups.google.com/group/clojure/browse_frm/thread/da1285c538f22bb5"}
37 clojure.contrib.condition
38 (:require clojure.contrib.condition.Condition)
39 (:import clojure.contrib.condition.Condition
40 clojure.lang.IPersistentMap)
41 (:use (clojure.contrib
42 [def :only (defvar)]
43 [seq :only (separate)])))
44
45 (defvar *condition*
46 "While a handler is running, bound to the condition being handled")
47
48 (defvar *selector*
49 "While a handler is running, bound to the selector returned by the
50 handler-case dispatch-fn for *condition*")
51
52 (defvar *condition-object*
53 "While a handler is running, bound to the Condition object whose metadata
54 is the condition")
55
56 (defvar *full-stack-traces* false
57 "Bind to true to include clojure.{core,lang,main} frames in stack
58 traces")
59
60 (defmacro raise
61 "Raises a condition. With no arguments, re-raises the current condition.
62 With one argument (a map), raises the argument. With two or more
63 arguments, raises a map with keys and values from the arguments."
64 ([]
65 `(throw *condition-object*))
66 ([m]
67 `(throw (Condition. ~m)))
68 ([key val & keyvals]
69 `(raise (hash-map ~key ~val ~@keyvals))))
70
71 (defmacro handler-case
72 "Executes body in a context where raised conditions can be handled.
73
74 dispatch-fn accepts a raised condition (a map) and returns a selector
75 used to choose a handler. Commonly, dispatch-fn will be :type to dispatch
76 on the condition's :type value.
77
78 Handlers are forms within body:
79
80 (handle key
81 ...)
82
83 If a condition is raised, executes the body of the first handler whose
84 key satisfies (isa? selector key). If no handlers match, re-raises the
85 condition.
86
87 While a handler is running, *condition* is bound to the condition being
88 handled and *selector* is bound to to the value returned by dispatch-fn
89 that matched the handler's key."
90 [dispatch-fn & body]
91 (let [[handlers code]
92 (separate #(and (list? %) (= 'handle (first %))) body)]
93 `(try
94 ~@code
95 (catch Condition c#
96 (binding [*condition-object* c#
97 *condition* (meta c#)
98 *selector* (~dispatch-fn (meta c#))]
99 (cond
100 ~@(mapcat
101 (fn [[_ key & body]]
102 `[(isa? *selector* ~key) (do ~@body)])
103 handlers)
104 :else (raise)))))))
105
106 (defmulti stack-trace-info
107 "Returns header, stack-trace, and cause info from conditions and
108 Throwables"
109 class)
110
111 (defmethod stack-trace-info IPersistentMap
112 [condition]
113 [(format "condition: %s, %s" (:type condition)
114 (dissoc condition :type :stack-trace :cause))
115 (:stack-trace condition)
116 (:cause condition)])
117
118 (defmethod stack-trace-info Condition
119 [condition]
120 (stack-trace-info (meta condition)))
121
122 (defmethod stack-trace-info Throwable
123 [throwable]
124 [(str throwable)
125 (.getStackTrace throwable)
126 (.getCause throwable)])
127
128 (defn print-stack-trace
129 "Prints a stack trace for a condition or Throwable. Skips frames for
130 classes in clojure.{core,lang,main} unless the *full-stack-traces* is
131 bound to logical true"
132 [x]
133 (let [[header frames cause] (stack-trace-info x)]
134 (printf "%s\n" header)
135 (doseq [frame frames]
136 (let [classname (.getClassName frame)]
137 (if (or *full-stack-traces*
138 (not (re-matches
139 #"clojure.(?:core|lang|main).*" classname)))
140 (printf " at %s/%s(%s:%s)\n"
141 classname
142 (.getMethodName frame)
143 (.getFileName frame)
144 (.getLineNumber frame)))))
145 (when cause
146 (printf "caused by: ")
147 (recur cause))))