Split all namespaces into sub-modules.

* Examples and tests have not been copied over.
* Clojure test/compile phases are commented out in parent POM.
* May require installing parent POM before full build.

2 files changed, 310 insertions, 0 deletions

diff --git a/modules/error-kit/pom.xml b/modules/error-kit/pom.xml
new file mode 100644
index 00000000..fed9997b
--- /dev/null
+++ b/modules/error-kit/pom.xml
@@ -0,0 +1,21 @@
+<?xml version="1.0" encoding="UTF-8"?>
+<project xmlns="http://maven.apache.org/POM/4.0.0"
+         xmlns:xsi="http//www.w3.org/2001/XMLSchema-instance"
+         xsi:schemaLocation="http://maven.apache.org/POM/4.0.0
+                             http://maven.apache.org/maven-v4_0_0.xsd">
+  <modelVersion>4.0.0</modelVersion>
+  <parent>
+    <groupId>org.clojure.contrib</groupId>
+    <artifactId>parent</artifactId>
+    <version>1.3.0-SNAPSHOT</version>
+    <relativePath>../parent</relativePath>
+  </parent>
+  <artifactId>error-kit</artifactId>
+  <dependencies>
+    <dependency>
+      <groupId>org.clojure.contrib</groupId>
+      <artifactId>def</artifactId>
+      <version>1.3.0-SNAPSHOT</version>
+    </dependency>
+  </dependencies>
+</project>
\ No newline at end of file
diff --git a/modules/error-kit/src/main/clojure/clojure/contrib/error_kit.clj b/modules/error-kit/src/main/clojure/clojure/contrib/error_kit.clj
new file mode 100644
index 00000000..6cffd859
--- /dev/null
+++ b/modules/error-kit/src/main/clojure/clojure/contrib/error_kit.clj
@@ -0,0 +1,289 @@
+;   Copyright (c) Chris Houser, Jan 2009. 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.
+
+; == EXPERIMENTAL ==
+; System for defining and using custom errors
+; Please contact Chouser if you have any suggestions for better names
+; or API adjustments.
+
+(ns 
+  ^{:author "Chris Houser",
+     :doc "EXPERIMENTAL
+System for defining and using custom errors
+Please contact Chouser if you have any suggestions for better names
+or API adjustments."} 
+  clojure.contrib.error-kit
+  (:use [clojure.contrib.def :only (defvar defvar-)]
+        [clojure.stacktrace :only (root-cause)]))
+
+(defn- make-ctrl-exception [msg data]
+  "Create an exception object with associated data, used for passing
+  control and data to a dynamically containing handler."
+  (proxy [Error clojure.lang.IDeref] [msg]
+    (toString [] (str "Error Kit Control Exception: " msg ", " (pr-str data)))
+    (deref [] data)))
+
+(defvar- ctrl-exception-class
+  (class (make-ctrl-exception nil nil)))
+
+(defvar- *handler-stack* () "Stack of bound handler symbols")
+
+(defvar- *continues* {} "Map of currently available continue forms")
+
+
+(defmacro throw-msg
+  "Returns a function that throws a Java Exception with the given
+  name.  Useful to associate a new error-kit error type with a
+  particular Java Exception class, via the :unhandled error key."
+  [class-name]
+  `(fn [x#] (throw (new ~class-name (:msg x#)))))
+
+(defn error
+  "Base type for all error-kit errors"
+  {::args [:msg :unhandled :tag]}
+  [details]
+  (merge {:tag `error :msg "exception via error-kit"
+          :unhandled (throw-msg Exception)}
+         details))
+
+(defn- qualify-sym [sym]
+  (let [v (resolve sym)]
+    (assert v)
+    (apply symbol (map #(str (% (meta v))) [:ns :name]))))
+
+(defmacro deferror
+  "Define a new error type"
+  {:arglists '([name [parent-error?] doc-string? [args*] & body]
+               [name [parent-error?] doc-string? args-destruct-map & body])}
+  [err-name pvec & decl]
+  (let [pvec (if (empty? pvec) [`error] pvec)
+        [docstr args & body] (if (string? (first decl)) decl (cons nil decl))
+        args (or args [])
+        argmap (if (vector? args) `{:keys ~args} args)
+        body (or body {})
+        qual-err-name (symbol (str *ns*) (name err-name))]
+    (assert (== (count pvec) 1)) ; only support single-inheritance for now
+    (assert (vector? args)) ; only vector (keyword destruct) args for now
+    `(do
+       (defn ~err-name [details#]
+         (let [basedata# ((resolve (first (parents '~qual-err-name))) details#)
+               ~argmap basedata#]
+           (merge basedata# {:tag '~qual-err-name} (do ~@body) details#)))
+       (alter-meta! (var ~err-name) assoc
+                    :doc ~docstr ::args ~(vec (map #(keyword (str %)) args)))
+       ~@(for [parent pvec]
+           `(derive '~qual-err-name '~(qualify-sym parent)))
+       (var ~err-name))))
+
+(defn- throw-to [msg target-map args]
+  (throw (make-ctrl-exception msg (assoc target-map :args args))))
+
+(defn raise*
+  "Raise the given error object, best if created by an error
+  constructor defined with deferror.  See also 'raise' macro."
+  [err]
+  (let [err-tag (:tag err)]
+    (loop [hs *handler-stack*]
+      (if (empty? hs)
+        ((:unhandled err) err)
+        (let [[{:keys [htag] :as handler}] hs]
+          (if (and htag (not (isa? err-tag htag)))
+            (recur (next hs))
+            (let [rtn ((:hfunc handler) err)]
+              (if-not (vector? rtn)
+                (throw-to "default" handler (list rtn))
+                (condp = (rtn 0)
+                  ::continue-with (rtn 1)
+                  ::continue (if-let [continue (*continues* (rtn 1))]
+                               (throw-to "continue" continue (rtn 2))
+                               (do (prn *continues*) (throw
+                                 (Exception.
+                                   (str "Unbound continue name " (rtn 1))))))
+                  ::do-not-handle (recur (next hs))
+                  (throw-to "do-not-handle" handler (list rtn)))))))))))
+
+(defmacro raise
+  "Raise an error of the type err-name, constructed with the given args"
+  [err-name & args]
+  `(raise* (~err-name ~(zipmap (::args (meta (resolve err-name)))
+                               args))))
+
+; It'd be nice to assert that these are used in a tail position of a handler
+(defmacro do-not-handle
+  "Use in a tail position of a 'handle' form to indicate 'raise' should
+  not consider the error handled, but should continue searching for an
+  appropriate 'handle' form.  Allows finer-grain control over catching
+  than just the error type."
+  []
+  `[::do-not-handle])
+
+(defmacro continue-with [value]
+  "Use in a tail position of a 'handle' form to cause the currently
+  running 'raise' to return the given 'value'."
+  `[::continue-with ~value])
+
+(defmacro continue [continue-name & args]
+  "Use in a tail position of a 'handle' form to pass control to the
+  named 'continue' form, passing in the given args.  The 'continue'
+  form with the given name and the smallest dynamic scope surrounding
+  the currently running 'raise' will be used."
+  `[::continue '~continue-name [~@args]])
+
+
+(def ^{:doc "Special form to be used inside a 'with-handler'.  When
+  any error is 'raised' from withing the dynamic scope of 'body' that
+  is of error-name's type or a derived type, the args will be bound
+  and the body executed.  If no 'error-name' is given, the body will
+  be executed for regardless of the type of error raised.  The body
+  may return a value, in which case that will be the return value of
+  the entire 'with-handler' form, or it may use any of the special
+  return forms, 'do-not-handle', 'continue-with', or 'continue'."
+          :arglists '([error-name? [args*] & body]
+                      [error-name? args-destruct-map-args & body])}
+  handle)
+
+(def ^{:doc "Special form to be used inside a 'with-handler'.
+  Control can be passed to this 'continue' form from a 'raise' enclosed
+  in this with-handler's dynamic scope, when this 'continue-name' is
+  given to a 'continue' form."
+        :arglists '([continue-name [args*] & body])}
+  bind-continue)
+
+(defn- special-form [form]
+  (and (list form)
+       (symbol? (first form))
+       (#{#'handle #'bind-continue} (resolve (first form)))))
+
+
+(defmacro with-handler
+  "This is error-kit's dynamic scope form.  The body will be executed
+  in a dynamic context that includes all of the following 'handle' and
+  'bind-continue' forms."
+  [& forms]
+  (let [[body special-forms] (split-with (complement special-form) forms)]
+    (assert (every? special-form special-forms))
+    (let [blockid (gensym)
+          handlers (for [[type & more] special-forms
+                         :when (= (resolve type) #'handle)]
+                     (let [[htag args & hbody] (if (symbol? (first more))
+                                                 more
+                                                 (cons nil more))
+                           argmap (if (vector? args) `{:keys ~args} args)]
+                       `{:blockid '~blockid
+                         :htag ~(when htag (list `quote (qualify-sym htag)))
+                         :hfunc (fn [~argmap] ~@hbody)
+                         :rfunc identity}))
+          continues (into {}
+                          (for [[type & more] special-forms
+                                :when (= (resolve type) #'bind-continue)]
+                            [(list `quote (first more))
+                             `{:blockid '~blockid
+                               :rfunc (fn ~@(next more))}]))]
+      `(try
+         (binding [*handler-stack* (list* ~@handlers @#'*handler-stack*)
+                   *continues* (merge @#'*continues* ~@continues)]
+           ~@body)
+         (catch Throwable e#
+           (let [root-cause# (root-cause e#)]
+             (if-not (instance? @#'ctrl-exception-class root-cause#)
+               (throw e#)
+               (let [data# @root-cause#]
+                 (if (= '~blockid (:blockid data#))
+                   (apply (:rfunc data#) (:args data#))
+                   (throw e#))))))))))
+
+(defn rebind-fn [func]
+  (let [a *handler-stack*, b *continues*]
+    (fn [& args]
+      (binding [*handler-stack* a
+                *continues* b]
+        (apply func args)))))
+
+(comment
+
+(alias 'kit 'clojure.contrib.error-kit)
+
+; This defines an error and its action if unhandled.  A good choice of
+; unhandled. action is to throw a Java exception so users of your code
+; who do not want to use error-kit can still use normal Java try/catch
+; forms to handle the error.
+(kit/deferror number-error [] [n]
+  {:msg (str "Number error: " n)
+   :unhandled (kit/throw-msg NumberFormatException)})
+
+(kit/deferror odd-number-error [number-error]
+  "Indicates an odd number was given to an operation that is only
+  defined for even numbers."
+  [n]
+  {:msg (str "Can't handle odd number: " n)})
+
+; Raise an error by name with any extra args defined by the deferror
+(defn int-half [i]
+  (if (even? i)
+    (quot i 2)
+    (kit/raise odd-number-error i)))
+
+; Throws Java NumberFormatException because there's no 'handle' form
+(vec (map int-half [2 4 5 8]))
+
+; Throws Java Exception with details provided by 'raise'
+(kit/with-handler
+  (vec (map int-half [2 4 5 8]))
+  (kit/handle odd-number-error [n]
+    (throw (Exception. (format "Odd number %d in vector." n)))))
+
+; The above is equivalent to the more complicated version below:
+(kit/with-handler
+  (vec (map int-half [2 4 5 8]))
+  (kit/handle {:keys [n tag]}
+    (if (isa? tag `odd-number-error)
+      (throw (Exception. (format "Odd number %d in vector." n)))
+      (kit/do-not-handle))))
+
+; Returns "invalid" string instead of a vector when an error is encountered
+(kit/with-handler
+  (vec (map int-half [2 4 5 8]))
+  (kit/handle kit/error [n]
+    "invalid"))
+
+; Inserts a zero into the returned vector where there was an error, in
+; this case [1 2 0 4]
+(kit/with-handler
+  (vec (map int-half [2 4 5 8]))
+  (kit/handle number-error [n]
+    (kit/continue-with 0)))
+
+; Intermediate continue: [1 2 :oops 5 4]
+(defn int-half-vec [s]
+  (reduce (fn [v i]
+            (kit/with-handler
+              (conj v (int-half i))
+              (kit/bind-continue instead-of-half [& instead-seq]
+                (apply conj v instead-seq))))
+    [] s))
+
+(kit/with-handler
+  (int-half-vec [2 4 5 8])
+  (kit/handle number-error [n]
+    (kit/continue instead-of-half :oops n)))
+
+; Notes:
+
+; It seems likely you'd want to convert a handle clause to
+; bind-continue, since it would allow higher forms to request what you
+; used to do by default.  Thus both should appear in the same
+; with-handler form
+
+; Should continue-names be namespace qualified, and therefore require
+; pre-definition in some namespace?
+; (kit/defcontinue skip-thing "docstring")
+
+; Could add 'catch' for Java Exceptions and 'finally' support to
+; with-handler forms.
+
+)