1.1 --- /dev/null	Thu Jan 01 00:00:00 1970 +0000
     1.2 +++ b/src/clojure/contrib/error_kit.clj	Sat Aug 21 06:25:44 2010 -0400
     1.3 @@ -0,0 +1,289 @@
     1.4 +;   Copyright (c) Chris Houser, Jan 2009. All rights reserved.
     1.5 +;   The use and distribution terms for this software are covered by the
     1.6 +;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)
     1.7 +;   which can be found in the file epl-v10.html at the root of this distribution.
     1.8 +;   By using this software in any fashion, you are agreeing to be bound by
     1.9 +;   the terms of this license.
    1.10 +;   You must not remove this notice, or any other, from this software.
    1.11 +
    1.12 +; == EXPERIMENTAL ==
    1.13 +; System for defining and using custom errors
    1.14 +; Please contact Chouser if you have any suggestions for better names
    1.15 +; or API adjustments.
    1.16 +
    1.17 +(ns 
    1.18 +  ^{:author "Chris Houser",
    1.19 +     :doc "EXPERIMENTAL
    1.20 +System for defining and using custom errors
    1.21 +Please contact Chouser if you have any suggestions for better names
    1.22 +or API adjustments."} 
    1.23 +  clojure.contrib.error-kit
    1.24 +  (:use [clojure.contrib.def :only (defvar defvar-)]
    1.25 +        [clojure.stacktrace :only (root-cause)]))
    1.26 +
    1.27 +(defn- make-ctrl-exception [msg data]
    1.28 +  "Create an exception object with associated data, used for passing
    1.29 +  control and data to a dynamically containing handler."
    1.30 +  (proxy [Error clojure.lang.IDeref] [msg]
    1.31 +    (toString [] (str "Error Kit Control Exception: " msg ", " (pr-str data)))
    1.32 +    (deref [] data)))
    1.33 +
    1.34 +(defvar- ctrl-exception-class
    1.35 +  (class (make-ctrl-exception nil nil)))
    1.36 +
    1.37 +(defvar- *handler-stack* () "Stack of bound handler symbols")
    1.38 +
    1.39 +(defvar- *continues* {} "Map of currently available continue forms")
    1.40 +
    1.41 +
    1.42 +(defmacro throw-msg
    1.43 +  "Returns a function that throws a Java Exception with the given
    1.44 +  name.  Useful to associate a new error-kit error type with a
    1.45 +  particular Java Exception class, via the :unhandled error key."
    1.46 +  [class-name]
    1.47 +  `(fn [x#] (throw (new ~class-name (:msg x#)))))
    1.48 +
    1.49 +(defn error
    1.50 +  "Base type for all error-kit errors"
    1.51 +  {::args [:msg :unhandled :tag]}
    1.52 +  [details]
    1.53 +  (merge {:tag `error :msg "exception via error-kit"
    1.54 +          :unhandled (throw-msg Exception)}
    1.55 +         details))
    1.56 +
    1.57 +(defn- qualify-sym [sym]
    1.58 +  (let [v (resolve sym)]
    1.59 +    (assert v)
    1.60 +    (apply symbol (map #(str (% (meta v))) [:ns :name]))))
    1.61 +
    1.62 +(defmacro deferror
    1.63 +  "Define a new error type"
    1.64 +  {:arglists '([name [parent-error?] doc-string? [args*] & body]
    1.65 +               [name [parent-error?] doc-string? args-destruct-map & body])}
    1.66 +  [err-name pvec & decl]
    1.67 +  (let [pvec (if (empty? pvec) [`error] pvec)
    1.68 +        [docstr args & body] (if (string? (first decl)) decl (cons nil decl))
    1.69 +        args (or args [])
    1.70 +        argmap (if (vector? args) `{:keys ~args} args)
    1.71 +        body (or body {})
    1.72 +        qual-err-name (symbol (str *ns*) (name err-name))]
    1.73 +    (assert (== (count pvec) 1)) ; only support single-inheritance for now
    1.74 +    (assert (vector? args)) ; only vector (keyword destruct) args for now
    1.75 +    `(do
    1.76 +       (defn ~err-name [details#]
    1.77 +         (let [basedata# ((resolve (first (parents '~qual-err-name))) details#)
    1.78 +               ~argmap basedata#]
    1.79 +           (merge basedata# {:tag '~qual-err-name} (do ~@body) details#)))
    1.80 +       (alter-meta! (var ~err-name) assoc
    1.81 +                    :doc ~docstr ::args ~(vec (map #(keyword (str %)) args)))
    1.82 +       ~@(for [parent pvec]
    1.83 +           `(derive '~qual-err-name '~(qualify-sym parent)))
    1.84 +       (var ~err-name))))
    1.85 +
    1.86 +(defn- throw-to [msg target-map args]
    1.87 +  (throw (make-ctrl-exception msg (assoc target-map :args args))))
    1.88 +
    1.89 +(defn raise*
    1.90 +  "Raise the given error object, best if created by an error
    1.91 +  constructor defined with deferror.  See also 'raise' macro."
    1.92 +  [err]
    1.93 +  (let [err-tag (:tag err)]
    1.94 +    (loop [hs *handler-stack*]
    1.95 +      (if (empty? hs)
    1.96 +        ((:unhandled err) err)
    1.97 +        (let [[{:keys [htag] :as handler}] hs]
    1.98 +          (if (and htag (not (isa? err-tag htag)))
    1.99 +            (recur (next hs))
   1.100 +            (let [rtn ((:hfunc handler) err)]
   1.101 +              (if-not (vector? rtn)
   1.102 +                (throw-to "default" handler (list rtn))
   1.103 +                (condp = (rtn 0)
   1.104 +                  ::continue-with (rtn 1)
   1.105 +                  ::continue (if-let [continue (*continues* (rtn 1))]
   1.106 +                               (throw-to "continue" continue (rtn 2))
   1.107 +                               (do (prn *continues*) (throw
   1.108 +                                 (Exception.
   1.109 +                                   (str "Unbound continue name " (rtn 1))))))
   1.110 +                  ::do-not-handle (recur (next hs))
   1.111 +                  (throw-to "do-not-handle" handler (list rtn)))))))))))
   1.112 +
   1.113 +(defmacro raise
   1.114 +  "Raise an error of the type err-name, constructed with the given args"
   1.115 +  [err-name & args]
   1.116 +  `(raise* (~err-name ~(zipmap (::args (meta (resolve err-name)))
   1.117 +                               args))))
   1.118 +
   1.119 +; It'd be nice to assert that these are used in a tail position of a handler
   1.120 +(defmacro do-not-handle
   1.121 +  "Use in a tail position of a 'handle' form to indicate 'raise' should
   1.122 +  not consider the error handled, but should continue searching for an
   1.123 +  appropriate 'handle' form.  Allows finer-grain control over catching
   1.124 +  than just the error type."
   1.125 +  []
   1.126 +  `[::do-not-handle])
   1.127 +
   1.128 +(defmacro continue-with [value]
   1.129 +  "Use in a tail position of a 'handle' form to cause the currently
   1.130 +  running 'raise' to return the given 'value'."
   1.131 +  `[::continue-with ~value])
   1.132 +
   1.133 +(defmacro continue [continue-name & args]
   1.134 +  "Use in a tail position of a 'handle' form to pass control to the
   1.135 +  named 'continue' form, passing in the given args.  The 'continue'
   1.136 +  form with the given name and the smallest dynamic scope surrounding
   1.137 +  the currently running 'raise' will be used."
   1.138 +  `[::continue '~continue-name [~@args]])
   1.139 +
   1.140 +
   1.141 +(def ^{:doc "Special form to be used inside a 'with-handler'.  When
   1.142 +  any error is 'raised' from withing the dynamic scope of 'body' that
   1.143 +  is of error-name's type or a derived type, the args will be bound
   1.144 +  and the body executed.  If no 'error-name' is given, the body will
   1.145 +  be executed for regardless of the type of error raised.  The body
   1.146 +  may return a value, in which case that will be the return value of
   1.147 +  the entire 'with-handler' form, or it may use any of the special
   1.148 +  return forms, 'do-not-handle', 'continue-with', or 'continue'."
   1.149 +          :arglists '([error-name? [args*] & body]
   1.150 +                      [error-name? args-destruct-map-args & body])}
   1.151 +  handle)
   1.152 +
   1.153 +(def ^{:doc "Special form to be used inside a 'with-handler'.
   1.154 +  Control can be passed to this 'continue' form from a 'raise' enclosed
   1.155 +  in this with-handler's dynamic scope, when this 'continue-name' is
   1.156 +  given to a 'continue' form."
   1.157 +        :arglists '([continue-name [args*] & body])}
   1.158 +  bind-continue)
   1.159 +
   1.160 +(defn- special-form [form]
   1.161 +  (and (list form)
   1.162 +       (symbol? (first form))
   1.163 +       (#{#'handle #'bind-continue} (resolve (first form)))))
   1.164 +
   1.165 +
   1.166 +(defmacro with-handler
   1.167 +  "This is error-kit's dynamic scope form.  The body will be executed
   1.168 +  in a dynamic context that includes all of the following 'handle' and
   1.169 +  'bind-continue' forms."
   1.170 +  [& forms]
   1.171 +  (let [[body special-forms] (split-with (complement special-form) forms)]
   1.172 +    (assert (every? special-form special-forms))
   1.173 +    (let [blockid (gensym)
   1.174 +          handlers (for [[type & more] special-forms
   1.175 +                         :when (= (resolve type) #'handle)]
   1.176 +                     (let [[htag args & hbody] (if (symbol? (first more))
   1.177 +                                                 more
   1.178 +                                                 (cons nil more))
   1.179 +                           argmap (if (vector? args) `{:keys ~args} args)]
   1.180 +                       `{:blockid '~blockid
   1.181 +                         :htag ~(when htag (list `quote (qualify-sym htag)))
   1.182 +                         :hfunc (fn [~argmap] ~@hbody)
   1.183 +                         :rfunc identity}))
   1.184 +          continues (into {}
   1.185 +                          (for [[type & more] special-forms
   1.186 +                                :when (= (resolve type) #'bind-continue)]
   1.187 +                            [(list `quote (first more))
   1.188 +                             `{:blockid '~blockid
   1.189 +                               :rfunc (fn ~@(next more))}]))]
   1.190 +      `(try
   1.191 +         (binding [*handler-stack* (list* ~@handlers @#'*handler-stack*)
   1.192 +                   *continues* (merge @#'*continues* ~@continues)]
   1.193 +           ~@body)
   1.194 +         (catch Throwable e#
   1.195 +           (let [root-cause# (root-cause e#)]
   1.196 +             (if-not (instance? @#'ctrl-exception-class root-cause#)
   1.197 +               (throw e#)
   1.198 +               (let [data# @root-cause#]
   1.199 +                 (if (= '~blockid (:blockid data#))
   1.200 +                   (apply (:rfunc data#) (:args data#))
   1.201 +                   (throw e#))))))))))
   1.202 +
   1.203 +(defn rebind-fn [func]
   1.204 +  (let [a *handler-stack*, b *continues*]
   1.205 +    (fn [& args]
   1.206 +      (binding [*handler-stack* a
   1.207 +                *continues* b]
   1.208 +        (apply func args)))))
   1.209 +
   1.210 +(comment
   1.211 +
   1.212 +(alias 'kit 'clojure.contrib.error-kit)
   1.213 +
   1.214 +; This defines an error and its action if unhandled.  A good choice of
   1.215 +; unhandled. action is to throw a Java exception so users of your code
   1.216 +; who do not want to use error-kit can still use normal Java try/catch
   1.217 +; forms to handle the error.
   1.218 +(kit/deferror number-error [] [n]
   1.219 +  {:msg (str "Number error: " n)
   1.220 +   :unhandled (kit/throw-msg NumberFormatException)})
   1.221 +
   1.222 +(kit/deferror odd-number-error [number-error]
   1.223 +  "Indicates an odd number was given to an operation that is only
   1.224 +  defined for even numbers."
   1.225 +  [n]
   1.226 +  {:msg (str "Can't handle odd number: " n)})
   1.227 +
   1.228 +; Raise an error by name with any extra args defined by the deferror
   1.229 +(defn int-half [i]
   1.230 +  (if (even? i)
   1.231 +    (quot i 2)
   1.232 +    (kit/raise odd-number-error i)))
   1.233 +
   1.234 +; Throws Java NumberFormatException because there's no 'handle' form
   1.235 +(vec (map int-half [2 4 5 8]))
   1.236 +
   1.237 +; Throws Java Exception with details provided by 'raise'
   1.238 +(kit/with-handler
   1.239 +  (vec (map int-half [2 4 5 8]))
   1.240 +  (kit/handle odd-number-error [n]
   1.241 +    (throw (Exception. (format "Odd number %d in vector." n)))))
   1.242 +
   1.243 +; The above is equivalent to the more complicated version below:
   1.244 +(kit/with-handler
   1.245 +  (vec (map int-half [2 4 5 8]))
   1.246 +  (kit/handle {:keys [n tag]}
   1.247 +    (if (isa? tag `odd-number-error)
   1.248 +      (throw (Exception. (format "Odd number %d in vector." n)))
   1.249 +      (kit/do-not-handle))))
   1.250 +
   1.251 +; Returns "invalid" string instead of a vector when an error is encountered
   1.252 +(kit/with-handler
   1.253 +  (vec (map int-half [2 4 5 8]))
   1.254 +  (kit/handle kit/error [n]
   1.255 +    "invalid"))
   1.256 +
   1.257 +; Inserts a zero into the returned vector where there was an error, in
   1.258 +; this case [1 2 0 4]
   1.259 +(kit/with-handler
   1.260 +  (vec (map int-half [2 4 5 8]))
   1.261 +  (kit/handle number-error [n]
   1.262 +    (kit/continue-with 0)))
   1.263 +
   1.264 +; Intermediate continue: [1 2 :oops 5 4]
   1.265 +(defn int-half-vec [s]
   1.266 +  (reduce (fn [v i]
   1.267 +            (kit/with-handler
   1.268 +              (conj v (int-half i))
   1.269 +              (kit/bind-continue instead-of-half [& instead-seq]
   1.270 +                (apply conj v instead-seq))))
   1.271 +    [] s))
   1.272 +
   1.273 +(kit/with-handler
   1.274 +  (int-half-vec [2 4 5 8])
   1.275 +  (kit/handle number-error [n]
   1.276 +    (kit/continue instead-of-half :oops n)))
   1.277 +
   1.278 +; Notes:
   1.279 +
   1.280 +; It seems likely you'd want to convert a handle clause to
   1.281 +; bind-continue, since it would allow higher forms to request what you
   1.282 +; used to do by default.  Thus both should appear in the same
   1.283 +; with-handler form
   1.284 +
   1.285 +; Should continue-names be namespace qualified, and therefore require
   1.286 +; pre-definition in some namespace?
   1.287 +; (kit/defcontinue skip-thing "docstring")
   1.288 +
   1.289 +; Could add 'catch' for Java Exceptions and 'finally' support to
   1.290 +; with-handler forms.
   1.291 +
   1.292 +)