condition: refinements

3 files changed, 97 insertions, 54 deletions

diff --git a/src/clojure/contrib/condition.clj b/src/clojure/contrib/condition.clj
index 4d7ad422..8df8acff 100644
--- a/src/clojure/contrib/condition.clj
+++ b/src/clojure/contrib/condition.clj
@@ -8,26 +8,27 @@
 ;;
 ;;  condition.clj
 ;;
-;;  Flexible raising and handling of conditions. A condition is a map
-;;  containing:
-;;
-;;    - keys and values specified as arguments to raise, and
-;;    - a stack trace at key :stack-trace.
-;;
-;;  Note: requires AOT compilation.
-;;
-;;  Based on an idea from Chouser:
-;;  http://groups.google.com/group/clojure/browse_frm/thread/da1285c538f22bb5
-;;
 ;;  scgilardi (gmail)
 ;;  Created 09 June 2009
 
 (ns #^{:author "Stephen C. Gilardi"
-       :doc "Flexible raising and handling of conditions. A condition is a map
-containing:
+       :doc "Flexible raising and handling of conditions:
+
+Functions:
+
+              raise: raises a condition
+       handler-case: dispatches raised conditions to appropriate handlers
+  print-stack-trace: prints abbreviated or full condition stack traces
+
+Data:
+
+  A condition is a map containing values for these keys:
 
-  - keys and values specified as arguments to raise, and
-  - a stack trace at key :stack-trace.
+    - :type, a condition type specifier, typically a keyword
+    - :stack-trace, a stack trace to the site of the raise
+    - :message, a human-readable message (optional)
+    - :cause, a wrapped exception or condition (optional)
+    - other keys given as arguments to raise (optional)
 
 Note: requires AOT compilation.
 
@@ -35,7 +36,8 @@ Based on an idea from Chouser:
 http://groups.google.com/group/clojure/browse_frm/thread/da1285c538f22bb5"}
   clojure.contrib.condition
   (:require clojure.contrib.condition.Condition)
-  (:import clojure.contrib.condition.Condition)
+  (:import clojure.contrib.condition.Condition
+           clojure.lang.IPersistentMap)
   (:use (clojure.contrib
          [def :only (defvar)]
          [seq-utils :only (separate)])))
@@ -44,12 +46,12 @@ http://groups.google.com/group/clojure/browse_frm/thread/da1285c538f22bb5"}
   "While a handler is running, bound to the condition being handled")
 
 (defvar *selector*
-  "While a handler is running, bound to the selector returned by
-  dispatch-fn for *condition*")
+  "While a handler is running, bound to the selector returned by the
+  handler-case dispatch-fn for *condition*")
 
 (defvar *condition-object*
   "While a handler is running, bound to the Condition object whose metadata
-  is the condition being handled")
+  is the condition")
 
 (defvar *full-stack-traces* false
   "Bind to true to include clojure.{core,lang,main} frames in stack
@@ -62,15 +64,16 @@ http://groups.google.com/group/clojure/browse_frm/thread/da1285c538f22bb5"}
   ([]
      `(throw *condition-object*))
   ([m]
-     `(throw (Condition. m)))
+     `(throw (Condition. ~m)))
   ([key val & keyvals]
-     `(throw (Condition. (hash-map ~key ~val ~@keyvals)))))
+     `(raise (hash-map ~key ~val ~@keyvals))))
 
 (defmacro handler-case
   "Executes body in a context where raised conditions can be handled.
 
   dispatch-fn accepts a raised condition (a map) and returns a selector
-  used to choose a handler.
+  used to choose a handler. Commonly, dispatch-fn will be :type to dispatch
+  on the condition's :type value.
 
   Handlers are forms within body:
 
@@ -100,20 +103,45 @@ http://groups.google.com/group/clojure/browse_frm/thread/da1285c538f22bb5"}
               handlers)
            :else (raise)))))))
 
-(defn print-stack-trace
-  "Prints the stack trace for a condition. Skips frames for classes in
-  clojure.{core,lang,main} unless the *full-stack-traces* is bound to
-  logical true"
+(defmulti stack-trace-info
+  "Returns header, stack-trace, and cause info from conditions and
+  Throwables"
+  class)
+
+(defmethod stack-trace-info IPersistentMap
+  [condition]
+  [(format "condition: %s, %s" (:type condition)
+           (dissoc condition :type :stack-trace :cause))
+   (:stack-trace condition)
+   (:cause condition)])
+
+(defmethod stack-trace-info Condition
   [condition]
-  (printf "condition: %s\n"
-          (dissoc condition :stack-trace))
-  (doseq [frame (:stack-trace condition)]
-    (let [classname (.getClassName frame)]
-      (if (or *full-stack-traces*
-              (not (re-matches
-                    #"clojure.(?:core|lang|main).*" classname)))
-        (printf "        at %s/%s(%s:%s)\n"
-                classname
-                (.getMethodName frame)
-                (.getFileName frame)
-                (.getLineNumber frame))))))
+  (stack-trace-info ^condition))
+
+(defmethod stack-trace-info Throwable
+  [throwable]
+  [(str throwable)
+   (.getStackTrace throwable)
+   (.getCause throwable)])
+
+(defn print-stack-trace
+  "Prints a stack trace for a condition or Throwable. Skips frames for
+  classes in clojure.{core,lang,main} unless the *full-stack-traces* is
+  bound to logical true"
+  [x]
+  (let [[header frames cause] (stack-trace-info x)]
+    (printf "%s\n" header)
+    (doseq [frame frames]
+      (let [classname (.getClassName frame)]
+        (if (or *full-stack-traces*
+                (not (re-matches
+                      #"clojure.(?:core|lang|main).*" classname)))
+          (printf "        at %s/%s(%s:%s)\n"
+                  classname
+                  (.getMethodName frame)
+                  (.getFileName frame)
+                  (.getLineNumber frame)))))
+    (when cause
+      (printf "caused by: ")
+      (recur cause))))
diff --git a/src/clojure/contrib/condition/Condition.clj b/src/clojure/contrib/condition/Condition.clj
index b3a24340..18449653 100644
--- a/src/clojure/contrib/condition/Condition.clj
+++ b/src/clojure/contrib/condition/Condition.clj
@@ -16,16 +16,28 @@
 (ns clojure.contrib.condition.Condition
   (:gen-class :extends Throwable
               :implements [clojure.lang.IMeta]
-              :state _meta
+              :state state
               :init init
-              :constructors
-              {[clojure.lang.IPersistentMap] []}))
+              :post-init post-init
+              :constructors {[clojure.lang.IPersistentMap]
+                             [String Throwable]}))
 
 (defn -init
-  [meta]
-  [[] meta])
+  "Constructs a Condition object with condition (a map) as its
+  metadata. Also initializes the superclass with the values at :message
+  and :cause, if any, so they are also available via .getMessage and
+  .getCause."
+  [condition]
+  [[(:message condition) (:cause condition)] (atom condition)])
+
+(defn -post-init
+  "Adds :stack-trace to the condition. Drops the bottom 3 frames because
+  they are always the same: implementation details of Condition and raise."
+  [this condition]
+  (swap! (.state this) assoc
+         :stack-trace (into-array (drop 3 (.getStackTrace this)))))
 
 (defn -meta
+  "Returns this object's metadata, the condition"
   [this]
-  (assoc (._meta this)
-    :stack-trace (into-array (drop 3 (.getStackTrace this)))))
+  @(.state this))
diff --git a/src/clojure/contrib/condition/example.clj b/src/clojure/contrib/condition/example.clj
index 36d7b36f..5a7d72ef 100644
--- a/src/clojure/contrib/condition/example.clj
+++ b/src/clojure/contrib/condition/example.clj
@@ -12,28 +12,31 @@
 ;;  Created 09 June 2009
 
 (ns clojure.contrib.condition.example
-  (:use clojure.contrib.condition))
+  (:use (clojure.contrib
+         [condition
+          :only (handler-case print-stack-trace raise *condition*)])))
 
 (defn func [x y]
-  (if (neg? x)
-    (raise :reason :illegal-argument :arg 'x :value x :message "cannot be negative")
-    (+ x y)))
+  "Raises an exception if x is negative"
+  (when (neg? x)
+    (raise :type :illegal-argument :arg 'x :value x))
+  (+ x y))
 
 (defn main
   []
   
   ;; simple handler
   
-  (handler-case :reason
+  (handler-case :type
     (println (func 3 4))
     (println (func -5 10))
     (handle :illegal-argument
-      (print-stack-trace *condition*))
+            (print-stack-trace *condition*))
     (println 3))
 
   ;; multiple handlers
   
-  (handler-case :reason
+  (handler-case :type
     (println (func 4 1))
     (println (func -3 22))
     (handle :overflow
@@ -43,8 +46,8 @@
 
   ;; nested handlers
 
-  (handler-case :reason
-    (handler-case :reason
+  (handler-case :type
+    (handler-case :type
       nil
       nil
       (println 1)