;;  Copyright (c) Stephen C. Gilardi. All rights reserved.  The use and

 ;;  distribution terms for this software are covered by the Eclipse Public

 ;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can

 ;;  be found in the file epl-v10.html at the root of this distribution.  By

 ;;  using this software in any fashion, you are agreeing to be bound by the

 ;;  terms of this license.  You must not remove this notice, or any other,

 ;;  from this software.

 ;;

 ;;  condition.clj

 ;;

 ;;  scgilardi (gmail)

 ;;  Created 09 June 2009

 

 (ns ^{:author "Stephen C. Gilardi"

        :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:

 

     - :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.

 

 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

            clojure.lang.IPersistentMap)

   (:use (clojure.contrib

          [def :only (defvar)]

          [seq :only (separate)])))

 

 (defvar *condition*

   "While a handler is running, bound to the condition being handled")

 

 (defvar *selector*

   "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")

 

 (defvar *full-stack-traces* false

   "Bind to true to include clojure.{core,lang,main} frames in stack

   traces")

 

 (defmacro raise

   "Raises a condition. With no arguments, re-raises the current condition.

   With one argument (a map), raises the argument. With two or more

   arguments, raises a map with keys and values from the arguments."

   ([]

      `(throw *condition-object*))

   ([m]

      `(throw (Condition. ~m)))

   ([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. Commonly, dispatch-fn will be :type to dispatch

   on the condition's :type value.

 

   Handlers are forms within body:

 

     (handle key

       ...)

 

   If a condition is raised, executes the body of the first handler whose

   key satisfies (isa? selector key). If no handlers match, re-raises the

   condition.

 

   While a handler is running, *condition* is bound to the condition being

   handled and *selector* is bound to to the value returned by dispatch-fn

   that matched the handler's key."

   [dispatch-fn & body]

   (let [[handlers code]

         (separate #(and (list? %) (= 'handle (first %))) body)]

     `(try

       ~@code

       (catch Condition c#

         (binding [*condition-object* c#

                   *condition* (meta c#)

                   *selector* (~dispatch-fn (meta c#))]

           (cond

            ~@(mapcat

               (fn [[_ key & body]]

                 `[(isa? *selector* ~key) (do ~@body)])

               handlers)

            :else (raise)))))))

 

 (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]

   (stack-trace-info (meta 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))))