rlm@10: ;;  Copyright (c) Stephen C. Gilardi. All rights reserved.  The use and
rlm@10: ;;  distribution terms for this software are covered by the Eclipse Public
rlm@10: ;;  License 1.0 (http://opensource.org/licenses/eclipse-1.0.php) which can
rlm@10: ;;  be found in the file epl-v10.html at the root of this distribution.  By
rlm@10: ;;  using this software in any fashion, you are agreeing to be bound by the
rlm@10: ;;  terms of this license.  You must not remove this notice, or any other,
rlm@10: ;;  from this software.
rlm@10: ;;
rlm@10: ;;  condition.clj
rlm@10: ;;
rlm@10: ;;  scgilardi (gmail)
rlm@10: ;;  Created 09 June 2009
rlm@10: 
rlm@10: (ns ^{:author "Stephen C. Gilardi"
rlm@10:        :doc "Flexible raising and handling of conditions:
rlm@10: 
rlm@10: Functions:
rlm@10: 
rlm@10:               raise: raises a condition
rlm@10:        handler-case: dispatches raised conditions to appropriate handlers
rlm@10:   print-stack-trace: prints abbreviated or full condition stack traces
rlm@10: 
rlm@10: Data:
rlm@10: 
rlm@10:   A condition is a map containing values for these keys:
rlm@10: 
rlm@10:     - :type, a condition type specifier, typically a keyword
rlm@10:     - :stack-trace, a stack trace to the site of the raise
rlm@10:     - :message, a human-readable message (optional)
rlm@10:     - :cause, a wrapped exception or condition (optional)
rlm@10:     - other keys given as arguments to raise (optional)
rlm@10: 
rlm@10: Note: requires AOT compilation.
rlm@10: 
rlm@10: Based on an idea from Chouser:
rlm@10: http://groups.google.com/group/clojure/browse_frm/thread/da1285c538f22bb5"}
rlm@10:   clojure.contrib.condition
rlm@10:   (:require clojure.contrib.condition.Condition)
rlm@10:   (:import clojure.contrib.condition.Condition
rlm@10:            clojure.lang.IPersistentMap)
rlm@10:   (:use (clojure.contrib
rlm@10:          [def :only (defvar)]
rlm@10:          [seq :only (separate)])))
rlm@10: 
rlm@10: (defvar *condition*
rlm@10:   "While a handler is running, bound to the condition being handled")
rlm@10: 
rlm@10: (defvar *selector*
rlm@10:   "While a handler is running, bound to the selector returned by the
rlm@10:   handler-case dispatch-fn for *condition*")
rlm@10: 
rlm@10: (defvar *condition-object*
rlm@10:   "While a handler is running, bound to the Condition object whose metadata
rlm@10:   is the condition")
rlm@10: 
rlm@10: (defvar *full-stack-traces* false
rlm@10:   "Bind to true to include clojure.{core,lang,main} frames in stack
rlm@10:   traces")
rlm@10: 
rlm@10: (defmacro raise
rlm@10:   "Raises a condition. With no arguments, re-raises the current condition.
rlm@10:   With one argument (a map), raises the argument. With two or more
rlm@10:   arguments, raises a map with keys and values from the arguments."
rlm@10:   ([]
rlm@10:      `(throw *condition-object*))
rlm@10:   ([m]
rlm@10:      `(throw (Condition. ~m)))
rlm@10:   ([key val & keyvals]
rlm@10:      `(raise (hash-map ~key ~val ~@keyvals))))
rlm@10: 
rlm@10: (defmacro handler-case
rlm@10:   "Executes body in a context where raised conditions can be handled.
rlm@10: 
rlm@10:   dispatch-fn accepts a raised condition (a map) and returns a selector
rlm@10:   used to choose a handler. Commonly, dispatch-fn will be :type to dispatch
rlm@10:   on the condition's :type value.
rlm@10: 
rlm@10:   Handlers are forms within body:
rlm@10: 
rlm@10:     (handle key
rlm@10:       ...)
rlm@10: 
rlm@10:   If a condition is raised, executes the body of the first handler whose
rlm@10:   key satisfies (isa? selector key). If no handlers match, re-raises the
rlm@10:   condition.
rlm@10: 
rlm@10:   While a handler is running, *condition* is bound to the condition being
rlm@10:   handled and *selector* is bound to to the value returned by dispatch-fn
rlm@10:   that matched the handler's key."
rlm@10:   [dispatch-fn & body]
rlm@10:   (let [[handlers code]
rlm@10:         (separate #(and (list? %) (= 'handle (first %))) body)]
rlm@10:     `(try
rlm@10:       ~@code
rlm@10:       (catch Condition c#
rlm@10:         (binding [*condition-object* c#
rlm@10:                   *condition* (meta c#)
rlm@10:                   *selector* (~dispatch-fn (meta c#))]
rlm@10:           (cond
rlm@10:            ~@(mapcat
rlm@10:               (fn [[_ key & body]]
rlm@10:                 `[(isa? *selector* ~key) (do ~@body)])
rlm@10:               handlers)
rlm@10:            :else (raise)))))))
rlm@10: 
rlm@10: (defmulti stack-trace-info
rlm@10:   "Returns header, stack-trace, and cause info from conditions and
rlm@10:   Throwables"
rlm@10:   class)
rlm@10: 
rlm@10: (defmethod stack-trace-info IPersistentMap
rlm@10:   [condition]
rlm@10:   [(format "condition: %s, %s" (:type condition)
rlm@10:            (dissoc condition :type :stack-trace :cause))
rlm@10:    (:stack-trace condition)
rlm@10:    (:cause condition)])
rlm@10: 
rlm@10: (defmethod stack-trace-info Condition
rlm@10:   [condition]
rlm@10:   (stack-trace-info (meta condition)))
rlm@10: 
rlm@10: (defmethod stack-trace-info Throwable
rlm@10:   [throwable]
rlm@10:   [(str throwable)
rlm@10:    (.getStackTrace throwable)
rlm@10:    (.getCause throwable)])
rlm@10: 
rlm@10: (defn print-stack-trace
rlm@10:   "Prints a stack trace for a condition or Throwable. Skips frames for
rlm@10:   classes in clojure.{core,lang,main} unless the *full-stack-traces* is
rlm@10:   bound to logical true"
rlm@10:   [x]
rlm@10:   (let [[header frames cause] (stack-trace-info x)]
rlm@10:     (printf "%s\n" header)
rlm@10:     (doseq [frame frames]
rlm@10:       (let [classname (.getClassName frame)]
rlm@10:         (if (or *full-stack-traces*
rlm@10:                 (not (re-matches
rlm@10:                       #"clojure.(?:core|lang|main).*" classname)))
rlm@10:           (printf "        at %s/%s(%s:%s)\n"
rlm@10:                   classname
rlm@10:                   (.getMethodName frame)
rlm@10:                   (.getFileName frame)
rlm@10:                   (.getLineNumber frame)))))
rlm@10:     (when cause
rlm@10:       (printf "caused by: ")
rlm@10:       (recur cause))))