1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/condition.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,147 @@
     1.4 +;;  Copyright (c) Stephen C. Gilardi. All rights reserved.  The use and
     1.5 +;;  distribution terms for this software are covered by the Eclipse Public
     1.6 +;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
     1.7 +;;  be found in the file epl-v10.html at the root of this distribution.  By
     1.8 +;;  using this software in any fashion, you are agreeing to be bound by the
     1.9 +;;  terms of this license.  You must not remove this notice, or any other,
    1.10 +;;  from this software.
    1.11 +;;
    1.12 +;;  condition.clj
    1.13 +;;
    1.14 +;;  scgilardi (gmail)
    1.15 +;;  Created 09 June 2009
    1.16 +
    1.17 +(ns ^{:author "Stephen C. Gilardi"
    1.18 +       :doc "Flexible raising and handling of conditions:
    1.19 +
    1.20 +Functions:
    1.21 +
    1.22 +              raise: raises a condition
    1.23 +       handler-case: dispatches raised conditions to appropriate handlers
    1.24 +  print-stack-trace: prints abbreviated or full condition stack traces
    1.25 +
    1.26 +Data:
    1.27 +
    1.28 +  A condition is a map containing values for these keys:
    1.29 +
    1.30 +    - :type, a condition type specifier, typically a keyword
    1.31 +    - :stack-trace, a stack trace to the site of the raise
    1.32 +    - :message, a human-readable message (optional)
    1.33 +    - :cause, a wrapped exception or condition (optional)
    1.34 +    - other keys given as arguments to raise (optional)
    1.35 +
    1.36 +Note: requires AOT compilation.
    1.37 +
    1.38 +Based on an idea from Chouser:
    1.39 +http://groups.google.com/group/clojure/browse_frm/thread/da1285c538f22bb5"}
    1.40 +  clojure.contrib.condition
    1.41 +  (:require clojure.contrib.condition.Condition)
    1.42 +  (:import clojure.contrib.condition.Condition
    1.43 +           clojure.lang.IPersistentMap)
    1.44 +  (:use (clojure.contrib
    1.45 +         [def :only (defvar)]
    1.46 +         [seq :only (separate)])))
    1.47 +
    1.48 +(defvar *condition*
    1.49 +  "While a handler is running, bound to the condition being handled")
    1.50 +
    1.51 +(defvar *selector*
    1.52 +  "While a handler is running, bound to the selector returned by the
    1.53 +  handler-case dispatch-fn for *condition*")
    1.54 +
    1.55 +(defvar *condition-object*
    1.56 +  "While a handler is running, bound to the Condition object whose metadata
    1.57 +  is the condition")
    1.58 +
    1.59 +(defvar *full-stack-traces* false
    1.60 +  "Bind to true to include clojure.{core,lang,main} frames in stack
    1.61 +  traces")
    1.62 +
    1.63 +(defmacro raise
    1.64 +  "Raises a condition. With no arguments, re-raises the current condition.
    1.65 +  With one argument (a map), raises the argument. With two or more
    1.66 +  arguments, raises a map with keys and values from the arguments."
    1.67 +  ([]
    1.68 +     `(throw *condition-object*))
    1.69 +  ([m]
    1.70 +     `(throw (Condition. ~m)))
    1.71 +  ([key val & keyvals]
    1.72 +     `(raise (hash-map ~key ~val ~@keyvals))))
    1.73 +
    1.74 +(defmacro handler-case
    1.75 +  "Executes body in a context where raised conditions can be handled.
    1.76 +
    1.77 +  dispatch-fn accepts a raised condition (a map) and returns a selector
    1.78 +  used to choose a handler. Commonly, dispatch-fn will be :type to dispatch
    1.79 +  on the condition's :type value.
    1.80 +
    1.81 +  Handlers are forms within body:
    1.82 +
    1.83 +    (handle key
    1.84 +      ...)
    1.85 +
    1.86 +  If a condition is raised, executes the body of the first handler whose
    1.87 +  key satisfies (isa? selector key). If no handlers match, re-raises the
    1.88 +  condition.
    1.89 +
    1.90 +  While a handler is running, *condition* is bound to the condition being
    1.91 +  handled and *selector* is bound to to the value returned by dispatch-fn
    1.92 +  that matched the handler's key."
    1.93 +  [dispatch-fn & body]
    1.94 +  (let [[handlers code]
    1.95 +        (separate #(and (list? %) (= 'handle (first %))) body)]
    1.96 +    `(try
    1.97 +      ~@code
    1.98 +      (catch Condition c#
    1.99 +        (binding [*condition-object* c#
   1.100 +                  *condition* (meta c#)
   1.101 +                  *selector* (~dispatch-fn (meta c#))]
   1.102 +          (cond
   1.103 +           ~@(mapcat
   1.104 +              (fn [[_ key & body]]
   1.105 +                `[(isa? *selector* ~key) (do ~@body)])
   1.106 +              handlers)
   1.107 +           :else (raise)))))))
   1.108 +
   1.109 +(defmulti stack-trace-info
   1.110 +  "Returns header, stack-trace, and cause info from conditions and
   1.111 +  Throwables"
   1.112 +  class)
   1.113 +
   1.114 +(defmethod stack-trace-info IPersistentMap
   1.115 +  [condition]
   1.116 +  [(format "condition: %s, %s" (:type condition)
   1.117 +           (dissoc condition :type :stack-trace :cause))
   1.118 +   (:stack-trace condition)
   1.119 +   (:cause condition)])
   1.120 +
   1.121 +(defmethod stack-trace-info Condition
   1.122 +  [condition]
   1.123 +  (stack-trace-info (meta condition)))
   1.124 +
   1.125 +(defmethod stack-trace-info Throwable
   1.126 +  [throwable]
   1.127 +  [(str throwable)
   1.128 +   (.getStackTrace throwable)
   1.129 +   (.getCause throwable)])
   1.130 +
   1.131 +(defn print-stack-trace
   1.132 +  "Prints a stack trace for a condition or Throwable. Skips frames for
   1.133 +  classes in clojure.{core,lang,main} unless the *full-stack-traces* is
   1.134 +  bound to logical true"
   1.135 +  [x]
   1.136 +  (let [[header frames cause] (stack-trace-info x)]
   1.137 +    (printf "%s\n" header)
   1.138 +    (doseq [frame frames]
   1.139 +      (let [classname (.getClassName frame)]
   1.140 +        (if (or *full-stack-traces*
   1.141 +                (not (re-matches
   1.142 +                      #"clojure.(?:core|lang|main).*" classname)))
   1.143 +          (printf "        at %s/%s(%s:%s)\n"
   1.144 +                  classname
   1.145 +                  (.getMethodName frame)
   1.146 +                  (.getFileName frame)
   1.147 +                  (.getLineNumber frame)))))
   1.148 +    (when cause
   1.149 +      (printf "caused by: ")
   1.150 +      (recur cause))))