Mercurial > lasercutter

     1 ;   Copyright (c) Chris Houser, Jan 2009. All rights reserved.

     2 ;   The use and distribution terms for this software are covered by the

     3 ;   Eclipse Public License 1.0 (http://opensource.org/licenses/eclipse-1.0.php)

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

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

     6 ;   the terms of this license.

     7 ;   You must not remove this notice, or any other, from this software.

     8 

     9 ; == EXPERIMENTAL ==

    10 ; System for defining and using custom errors

    11 ; Please contact Chouser if you have any suggestions for better names

    12 ; or API adjustments.

    13 

    14 (ns 

    15   ^{:author "Chris Houser",

    16      :doc "EXPERIMENTAL

    17 System for defining and using custom errors

    18 Please contact Chouser if you have any suggestions for better names

    19 or API adjustments."} 

    20   clojure.contrib.error-kit

    21   (:use [clojure.contrib.def :only (defvar defvar-)]

    22         [clojure.stacktrace :only (root-cause)]))

    23 

    24 (defn- make-ctrl-exception [msg data]

    25   "Create an exception object with associated data, used for passing

    26   control and data to a dynamically containing handler."

    27   (proxy [Error clojure.lang.IDeref] [msg]

    28     (toString [] (str "Error Kit Control Exception: " msg ", " (pr-str data)))

    29     (deref [] data)))

    30 

    31 (defvar- ctrl-exception-class

    32   (class (make-ctrl-exception nil nil)))

    33 

    34 (defvar- *handler-stack* () "Stack of bound handler symbols")

    35 

    36 (defvar- *continues* {} "Map of currently available continue forms")

    37 

    38 

    39 (defmacro throw-msg

    40   "Returns a function that throws a Java Exception with the given

    41   name.  Useful to associate a new error-kit error type with a

    42   particular Java Exception class, via the :unhandled error key."

    43   [class-name]

    44   `(fn [x#] (throw (new ~class-name (:msg x#)))))

    45 

    46 (defn error

    47   "Base type for all error-kit errors"

    48   {::args [:msg :unhandled :tag]}

    49   [details]

    50   (merge {:tag `error :msg "exception via error-kit"

    51           :unhandled (throw-msg Exception)}

    52          details))

    53 

    54 (defn- qualify-sym [sym]

    55   (let [v (resolve sym)]

    56     (assert v)

    57     (apply symbol (map #(str (% (meta v))) [:ns :name]))))

    58 

    59 (defmacro deferror

    60   "Define a new error type"

    61   {:arglists '([name [parent-error?] doc-string? [args*] & body]

    62                [name [parent-error?] doc-string? args-destruct-map & body])}

    63   [err-name pvec & decl]

    64   (let [pvec (if (empty? pvec) [`error] pvec)

    65         [docstr args & body] (if (string? (first decl)) decl (cons nil decl))

    66         args (or args [])

    67         argmap (if (vector? args) `{:keys ~args} args)

    68         body (or body {})

    69         qual-err-name (symbol (str *ns*) (name err-name))]

    70     (assert (== (count pvec) 1)) ; only support single-inheritance for now

    71     (assert (vector? args)) ; only vector (keyword destruct) args for now

    72     `(do

    73        (defn ~err-name [details#]

    74          (let [basedata# ((resolve (first (parents '~qual-err-name))) details#)

    75                ~argmap basedata#]

    76            (merge basedata# {:tag '~qual-err-name} (do ~@body) details#)))

    77        (alter-meta! (var ~err-name) assoc

    78                     :doc ~docstr ::args ~(vec (map #(keyword (str %)) args)))

    79        ~@(for [parent pvec]

    80            `(derive '~qual-err-name '~(qualify-sym parent)))

    81        (var ~err-name))))

    82 

    83 (defn- throw-to [msg target-map args]

    84   (throw (make-ctrl-exception msg (assoc target-map :args args))))

    85 

    86 (defn raise*

    87   "Raise the given error object, best if created by an error

    88   constructor defined with deferror.  See also 'raise' macro."

    89   [err]

    90   (let [err-tag (:tag err)]

    91     (loop [hs *handler-stack*]

    92       (if (empty? hs)

    93         ((:unhandled err) err)

    94         (let [[{:keys [htag] :as handler}] hs]

    95           (if (and htag (not (isa? err-tag htag)))

    96             (recur (next hs))

    97             (let [rtn ((:hfunc handler) err)]

    98               (if-not (vector? rtn)

    99                 (throw-to "default" handler (list rtn))

   100                 (condp = (rtn 0)

   101                   ::continue-with (rtn 1)

   102                   ::continue (if-let [continue (*continues* (rtn 1))]

   103                                (throw-to "continue" continue (rtn 2))

   104                                (do (prn *continues*) (throw

   105                                  (Exception.

   106                                    (str "Unbound continue name " (rtn 1))))))

   107                   ::do-not-handle (recur (next hs))

   108                   (throw-to "do-not-handle" handler (list rtn)))))))))))

   109 

   110 (defmacro raise

   111   "Raise an error of the type err-name, constructed with the given args"

   112   [err-name & args]

   113   `(raise* (~err-name ~(zipmap (::args (meta (resolve err-name)))

   114                                args))))

   115 

   116 ; It'd be nice to assert that these are used in a tail position of a handler

   117 (defmacro do-not-handle

   118   "Use in a tail position of a 'handle' form to indicate 'raise' should

   119   not consider the error handled, but should continue searching for an

   120   appropriate 'handle' form.  Allows finer-grain control over catching

   121   than just the error type."

   122   []

   123   `[::do-not-handle])

   124 

   125 (defmacro continue-with [value]

   126   "Use in a tail position of a 'handle' form to cause the currently

   127   running 'raise' to return the given 'value'."

   128   `[::continue-with ~value])

   129 

   130 (defmacro continue [continue-name & args]

   131   "Use in a tail position of a 'handle' form to pass control to the

   132   named 'continue' form, passing in the given args.  The 'continue'

   133   form with the given name and the smallest dynamic scope surrounding

   134   the currently running 'raise' will be used."

   135   `[::continue '~continue-name [~@args]])

   136 

   137 

   138 (def ^{:doc "Special form to be used inside a 'with-handler'.  When

   139   any error is 'raised' from withing the dynamic scope of 'body' that

   140   is of error-name's type or a derived type, the args will be bound

   141   and the body executed.  If no 'error-name' is given, the body will

   142   be executed for regardless of the type of error raised.  The body

   143   may return a value, in which case that will be the return value of

   144   the entire 'with-handler' form, or it may use any of the special

   145   return forms, 'do-not-handle', 'continue-with', or 'continue'."

   146           :arglists '([error-name? [args*] & body]

   147                       [error-name? args-destruct-map-args & body])}

   148   handle)

   149 

   150 (def ^{:doc "Special form to be used inside a 'with-handler'.

   151   Control can be passed to this 'continue' form from a 'raise' enclosed

   152   in this with-handler's dynamic scope, when this 'continue-name' is

   153   given to a 'continue' form."

   154         :arglists '([continue-name [args*] & body])}

   155   bind-continue)

   156 

   157 (defn- special-form [form]

   158   (and (list form)

   159        (symbol? (first form))

   160        (#{#'handle #'bind-continue} (resolve (first form)))))

   161 

   162 

   163 (defmacro with-handler

   164   "This is error-kit's dynamic scope form.  The body will be executed

   165   in a dynamic context that includes all of the following 'handle' and

   166   'bind-continue' forms."

   167   [& forms]

   168   (let [[body special-forms] (split-with (complement special-form) forms)]

   169     (assert (every? special-form special-forms))

   170     (let [blockid (gensym)

   171           handlers (for [[type & more] special-forms

   172                          :when (= (resolve type) #'handle)]

   173                      (let [[htag args & hbody] (if (symbol? (first more))

   174                                                  more

   175                                                  (cons nil more))

   176                            argmap (if (vector? args) `{:keys ~args} args)]

   177                        `{:blockid '~blockid

   178                          :htag ~(when htag (list `quote (qualify-sym htag)))

   179                          :hfunc (fn [~argmap] ~@hbody)

   180                          :rfunc identity}))

   181           continues (into {}

   182                           (for [[type & more] special-forms

   183                                 :when (= (resolve type) #'bind-continue)]

   184                             [(list `quote (first more))

   185                              `{:blockid '~blockid

   186                                :rfunc (fn ~@(next more))}]))]

   187       `(try

   188          (binding [*handler-stack* (list* ~@handlers @#'*handler-stack*)

   189                    *continues* (merge @#'*continues* ~@continues)]

   190            ~@body)

   191          (catch Throwable e#

   192            (let [root-cause# (root-cause e#)]

   193              (if-not (instance? @#'ctrl-exception-class root-cause#)

   194                (throw e#)

   195                (let [data# @root-cause#]

   196                  (if (= '~blockid (:blockid data#))

   197                    (apply (:rfunc data#) (:args data#))

   198                    (throw e#))))))))))

   199 

   200 (defn rebind-fn [func]

   201   (let [a *handler-stack*, b *continues*]

   202     (fn [& args]

   203       (binding [*handler-stack* a

   204                 *continues* b]

   205         (apply func args)))))

   206 

   207 (comment

   208 

   209 (alias 'kit 'clojure.contrib.error-kit)

   210 

   211 ; This defines an error and its action if unhandled.  A good choice of

   212 ; unhandled. action is to throw a Java exception so users of your code

   213 ; who do not want to use error-kit can still use normal Java try/catch

   214 ; forms to handle the error.

   215 (kit/deferror number-error [] [n]

   216   {:msg (str "Number error: " n)

   217    :unhandled (kit/throw-msg NumberFormatException)})

   218 

   219 (kit/deferror odd-number-error [number-error]

   220   "Indicates an odd number was given to an operation that is only

   221   defined for even numbers."

   222   [n]

   223   {:msg (str "Can't handle odd number: " n)})

   224 

   225 ; Raise an error by name with any extra args defined by the deferror

   226 (defn int-half [i]

   227   (if (even? i)

   228     (quot i 2)

   229     (kit/raise odd-number-error i)))

   230 

   231 ; Throws Java NumberFormatException because there's no 'handle' form

   232 (vec (map int-half [2 4 5 8]))

   233 

   234 ; Throws Java Exception with details provided by 'raise'

   235 (kit/with-handler

   236   (vec (map int-half [2 4 5 8]))

   237   (kit/handle odd-number-error [n]

   238     (throw (Exception. (format "Odd number %d in vector." n)))))

   239 

   240 ; The above is equivalent to the more complicated version below:

   241 (kit/with-handler

   242   (vec (map int-half [2 4 5 8]))

   243   (kit/handle {:keys [n tag]}

   244     (if (isa? tag `odd-number-error)

   245       (throw (Exception. (format "Odd number %d in vector." n)))

   246       (kit/do-not-handle))))

   247 

   248 ; Returns "invalid" string instead of a vector when an error is encountered

   249 (kit/with-handler

   250   (vec (map int-half [2 4 5 8]))

   251   (kit/handle kit/error [n]

   252     "invalid"))

   253 

   254 ; Inserts a zero into the returned vector where there was an error, in

   255 ; this case [1 2 0 4]

   256 (kit/with-handler

   257   (vec (map int-half [2 4 5 8]))

   258   (kit/handle number-error [n]

   259     (kit/continue-with 0)))

   260 

   261 ; Intermediate continue: [1 2 :oops 5 4]

   262 (defn int-half-vec [s]

   263   (reduce (fn [v i]

   264             (kit/with-handler

   265               (conj v (int-half i))

   266               (kit/bind-continue instead-of-half [& instead-seq]

   267                 (apply conj v instead-seq))))

   268     [] s))

   269 

   270 (kit/with-handler

   271   (int-half-vec [2 4 5 8])

   272   (kit/handle number-error [n]

   273     (kit/continue instead-of-half :oops n)))

   274 

   275 ; Notes:

   276 

   277 ; It seems likely you'd want to convert a handle clause to

   278 ; bind-continue, since it would allow higher forms to request what you

   279 ; used to do by default.  Thus both should appear in the same

   280 ; with-handler form

   281 

   282 ; Should continue-names be namespace qualified, and therefore require

   283 ; pre-definition in some namespace?

   284 ; (kit/defcontinue skip-thing "docstring")

   285 

   286 ; Could add 'catch' for Java Exceptions and 'finally' support to

   287 ; with-handler forms.

   288 

   289 )
author	Robert McIntyre <rlm@mit.edu>
date	Sat, 21 Aug 2010 06:25:44 -0400
parents
children