1 files changed, 388 insertions, 0 deletions
diff --git a/vim/bundle/slimv/swank-clojure/swank/core.clj b/vim/bundle/slimv/swank-clojure/swank/core.clj
new file mode 100644
index 0000000..892b6a8
--- /dev/null
+++ b/vim/bundle/slimv/swank-clojure/swank/core.clj
@@ -0,0 +1,388 @@
+(ns swank.core
+  (:use (swank util commands)
+        (swank.util hooks)
+        (swank.util.concurrent thread)
+        (swank.core connection hooks threadmap))
+  (:require (swank.util.concurrent [mbox :as mb])))
+
+;; Protocol version
+(defonce protocol-version (atom "20100404"))
+
+;; Emacs packages
+(def #^{:dynamic true} *current-package*)
+
+;; current emacs eval id
+(def #^{:dynamic true} *pending-continuations* '())
+
+(def sldb-stepping-p nil)
+(def sldb-initial-frames 10)
+(def #^{:dynamic true} #^{:doc "The current level of recursive debugging."}
+  *sldb-level* 0)
+(def #^{:dynamic true} #^{:doc "The current restarts."}
+  *sldb-restarts* 0)
+
+(def #^{:doc "Include swank-clojure thread in stack trace for debugger."}
+     debug-swank-clojure false)
+
+(defonce active-threads (ref ()))
+
+(defn maybe-ns [package]
+  (cond
+   (symbol? package) (or (find-ns package) (maybe-ns 'user))
+   (string? package) (maybe-ns (symbol package))
+   (keyword? package) (maybe-ns (name package))
+   (instance? clojure.lang.Namespace package) package
+   :else (maybe-ns 'user)))
+
+(defmacro with-emacs-package [& body]
+  `(binding [*ns* (maybe-ns *current-package*)]
+     ~@body))
+
+(defmacro with-package-tracking [& body]
+  `(let [last-ns# *ns*]
+     (try
+      ~@body
+      (finally
+       (when-not (= last-ns# *ns*)
+         (send-to-emacs `(:new-package ~(str (ns-name *ns*))
+                                       ~(str (ns-name *ns*)))))))))
+
+(defmacro dothread-swank [& body]
+  `(dothread-keeping-clj [*current-connection*]
+     ~@body))
+
+;; Exceptions for debugging
+(defonce debug-quit-exception (Exception. "Debug quit"))
+(defonce debug-continue-exception (Exception. "Debug continue"))
+(defonce debug-abort-exception (Exception. "Debug abort"))
+
+(def #^{:dynamic true} #^Throwable *current-exception* nil)
+
+;; Local environment
+(def #^{:dynamic true} *current-env* nil)
+
+(let [&env :unavailable]
+  (defmacro local-bindings
+    "Produces a map of the names of local bindings to their values."
+    []
+    (if-not (= &env :unavailable)
+      (let [symbols (keys &env)]
+        (zipmap (map (fn [sym] `(quote ~sym)) symbols) symbols)))))
+
+;; Handle Evaluation
+(defn send-to-emacs
+    "Sends a message (msg) to emacs."
+    ([msg]
+       (mb/send @(*current-connection* :control-thread) msg)))
+
+(defn send-repl-results-to-emacs [val]
+  (send-to-emacs `(:write-string ~(str (pr-str val) "\n") :repl-result)))
+
+(defn with-env-locals
+  "Evals a form with given locals. The locals should be a map of symbols to
+values."
+  [form]
+  (if (seq *current-env*)
+    `(let ~(vec (mapcat #(list % `(*current-env* '~%)) (keys *current-env*)))
+       ~form)
+    form))
+
+(defn eval-in-emacs-package [form]
+  (with-emacs-package
+   (eval form)))
+
+
+(defn eval-from-control
+  "Blocks for a mbox message from the control thread and executes it
+   when received. The mbox message is expected to be a slime-fn."
+  ([] (let [form (mb/receive (current-thread))]
+        (apply (ns-resolve *ns* (first form)) (rest form)))))
+
+(defn eval-loop
+  "A loop which continuosly reads actions from the control thread and
+   evaluates them (will block if no mbox message is available)."
+  ([] (continuously (eval-from-control))))
+
+(defn exception-causes [#^Throwable t]
+  (lazy-seq
+    (cons t (when-let [cause (.getCause t)]
+              (exception-causes cause)))))
+
+(defn- debug-quit-exception? [t]
+  (some #(identical? debug-quit-exception %) (exception-causes t)))
+
+(defn- debug-continue-exception? [t]
+  (some #(identical? debug-continue-exception %) (exception-causes t)))
+
+(defn- debug-abort-exception? [t]
+  (some #(identical? debug-abort-exception %) (exception-causes t)))
+
+(defn exception-stacktrace [t]
+  (map #(list %1 %2 '(:restartable nil))
+       (iterate inc 0)
+       (map str (.getStackTrace t))))
+
+(defn debugger-condition-for-emacs []
+  (list (or (.getMessage *current-exception*) "No message.")
+        (str "  [Thrown " (class *current-exception*) "]")
+        nil))
+
+(defn make-restart [kw name description f]
+  [kw [name description f]])
+
+(defn add-restart-if [condition restarts kw name description f]
+  (if condition
+    (conj restarts (make-restart kw name description f))
+    restarts))
+
+(declare sldb-debug)
+(defn cause-restart-for [thrown depth]
+  (make-restart
+   (keyword (str "cause" depth))
+   (str "CAUSE" depth)
+   (str "Invoke debugger on cause "
+        (apply str (take depth (repeat " ")))
+        (.getMessage thrown)
+        " [Thrown " (class thrown) "]")
+   (partial sldb-debug nil thrown *pending-continuations*)))
+
+(defn add-cause-restarts [restarts thrown]
+  (loop [restarts restarts
+         cause (.getCause thrown)
+         level 1]
+    (if cause
+      (recur
+       (conj restarts (cause-restart-for cause level))
+       (.getCause cause)
+       (inc level))
+      restarts)))
+
+(defn calculate-restarts [thrown]
+  (let [restarts [(make-restart :quit "QUIT" "Quit to the SLIME top level"
+                               (fn [] (throw debug-quit-exception)))]
+        restarts (add-restart-if
+                  (pos? *sldb-level*)
+                  restarts
+                  :abort "ABORT" (str "ABORT to SLIME level " (dec *sldb-level*))
+                  (fn [] (throw debug-abort-exception)))
+        restarts (add-restart-if
+                  (and (.getMessage thrown)
+                       (.contains (.getMessage thrown) "BREAK"))
+                  restarts
+                  :continue "CONTINUE" (str "Continue from breakpoint")
+                  (fn [] (throw debug-continue-exception)))
+        restarts (add-cause-restarts restarts thrown)]
+    (into (array-map) restarts)))
+
+(defn format-restarts-for-emacs []
+  (doall (map #(list (first (second %)) (second (second %))) *sldb-restarts*)))
+
+(defn build-backtrace [start end]
+  (doall (take (- end start) (drop start (exception-stacktrace *current-exception*)))))
+
+(defn build-debugger-info-for-emacs [start end]
+  (list (debugger-condition-for-emacs)
+        (format-restarts-for-emacs)
+        (build-backtrace start end)
+        *pending-continuations*))
+
+(defn sldb-loop
+  "A loop that is intented to take over an eval thread when a debug is
+   encountered (an continue to perform the same thing). It will
+   continue until a *debug-quit* exception is encountered."
+  [level]
+  (try
+   (send-to-emacs
+    (list* :debug (current-thread) level
+           (build-debugger-info-for-emacs 0 sldb-initial-frames)))
+   ([] (continuously
+        (do
+          (send-to-emacs `(:debug-activate ~(current-thread) ~level nil))
+          (eval-from-control))))
+   (catch Throwable t
+     (send-to-emacs
+      `(:debug-return ~(current-thread) ~*sldb-level* ~sldb-stepping-p))
+     (if-not (debug-continue-exception? t)
+       (throw t)))))
+
+(defn invoke-debugger
+  [locals #^Throwable thrown id]
+  (binding [*current-env* locals
+            *current-exception* thrown
+            *sldb-restarts* (calculate-restarts thrown)
+            *sldb-level* (inc *sldb-level*)]
+    (sldb-loop *sldb-level*)))
+
+(defn sldb-debug [locals thrown id]
+  (try
+   (invoke-debugger nil thrown id)
+   (catch Throwable t
+     (when (and (pos? *sldb-level*)
+                (not (debug-abort-exception? t)))
+       (throw t)))))
+
+(defmacro break
+  []
+  `(invoke-debugger (local-bindings) (Exception. "BREAK:") *pending-continuations*))
+
+(defn doall-seq [coll]
+  (if (seq? coll)
+    (doall coll)
+    coll))
+
+(defn eval-for-emacs [form buffer-package id]
+  (try
+   (binding [*current-package* buffer-package
+             *pending-continuations* (cons id *pending-continuations*)]
+     (if-let [f (slime-fn (first form))]
+       (let [form (cons f (rest form))
+             result (doall-seq (eval-in-emacs-package form))]
+         (run-hook pre-reply-hook)
+         (send-to-emacs `(:return ~(thread-name (current-thread))
+                                  (:ok ~result) ~id)))
+       ;; swank function not defined, abort
+       (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))))
+   (catch Throwable t
+     ;; Thread/interrupted clears this thread's interrupted status; if
+     ;; Thread.stop was called on us it may be set and will cause an
+     ;; InterruptedException in one of the send-to-emacs calls below
+     (Thread/interrupted)
+
+     ;; (.printStackTrace t #^java.io.PrintWriter *err*)
+
+     (cond
+      (debug-quit-exception? t)
+      (do
+        (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))
+        (if-not (zero? *sldb-level*)
+          (throw t)))
+
+      (debug-abort-exception? t)
+      (do
+        (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))
+        (if-not (zero? *sldb-level*)
+          (throw debug-abort-exception)))
+
+      (debug-continue-exception? t)
+      (do
+        (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id))
+        (throw t))
+
+      :else
+      (do
+        (set! *e t)
+        (try
+         (sldb-debug
+          nil
+          (if debug-swank-clojure t (or (.getCause t) t))
+          id)
+         ;; reply with abort
+         (finally (send-to-emacs `(:return ~(thread-name (current-thread)) (:abort) ~id)))))))))
+
+(defn- add-active-thread [thread]
+  (dosync
+   (commute active-threads conj thread)))
+
+(defn- remove-active-thread [thread]
+  (dosync
+   (commute active-threads (fn [threads] (remove #(= % thread) threads)))))
+
+(defn spawn-worker-thread
+  "Spawn an thread that blocks for a single command from the control
+   thread, executes it, then terminates."
+  ([conn]
+     (dothread-swank
+       (try
+        (add-active-thread (current-thread))
+        (thread-set-name "Swank Worker Thread")
+        (eval-from-control)
+        (finally
+         (remove-active-thread (current-thread)))))))
+
+(defn spawn-repl-thread
+  "Spawn an thread that sets itself as the current
+   connection's :repl-thread and then enters an eval-loop"
+  ([conn]
+     (dothread-swank
+      (thread-set-name "Swank REPL Thread")
+      (with-connection conn
+        (eval-loop)))))
+
+(defn find-or-spawn-repl-thread
+  "Returns the current connection's repl-thread or create a new one if
+   the existing one does not exist."
+  ([conn]
+     ;; TODO - check if an existing repl-agent is still active & doesn't have errors
+     (dosync
+      (or (when-let [conn-repl-thread @(conn :repl-thread)]
+            (when (.isAlive #^Thread conn-repl-thread)
+              conn-repl-thread))
+          (ref-set (conn :repl-thread)
+                   (spawn-repl-thread conn))))))
+
+(defn thread-for-evaluation
+  "Given an id and connection, find or create the appropiate agent."
+  ([id conn]
+     (cond
+      (= id true) (spawn-worker-thread conn)
+      (= id :repl-thread) (find-or-spawn-repl-thread conn)
+      :else (find-thread id))))
+
+;; Handle control
+(defn read-loop
+  "A loop that reads from the socket (will block when no message
+   available) and dispatches the message to the control thread."
+  ([conn control]
+     (with-connection conn
+       (continuously (mb/send control (read-from-connection conn))))))
+
+(defn dispatch-event
+   "Dispatches/executes an event in the control thread's mailbox queue."
+   ([ev conn]
+      (let [[action & args] ev]
+        (cond
+         (= action :emacs-rex)
+         (let [[form-string package thread id] args
+               thread (thread-for-evaluation thread conn)]
+           (mb/send thread `(eval-for-emacs ~form-string ~package ~id)))
+
+         (= action :return)
+         (let [[thread & ret] args]
+           (binding [*print-level* nil, *print-length* nil]
+             (write-to-connection conn `(:return ~@ret))))
+
+         (one-of? action
+                  :presentation-start :presentation-end
+                  :new-package :new-features :ed :percent-apply
+                  :indentation-update
+                  :eval-no-wait :background-message :inspect)
+         (binding [*print-level* nil, *print-length* nil]
+           (write-to-connection conn ev))
+
+         (= action :write-string)
+         (write-to-connection conn ev)
+
+         (one-of? action
+                  :debug :debug-condition :debug-activate :debug-return)
+         (let [[thread & args] args]
+           (write-to-connection conn `(~action ~(thread-map-id thread) ~@args)))
+
+         (= action :emacs-interrupt)
+         (let [[thread & args] args]
+           (dosync
+            (cond
+             (and (true? thread) (seq @active-threads))
+             (.stop #^Thread (first @active-threads))
+              (= thread :repl-thread) (.stop #^Thread @(conn :repl-thread)))))
+         :else
+         nil))))
+
+;; Main loop definitions
+(defn control-loop
+  "A loop that reads from the mbox queue and runs dispatch-event on
+   it (will block if no mbox control message is available). This is
+   intended to only be run on the control thread."
+  ([conn]
+     (binding [*1 nil, *2 nil, *3 nil, *e nil]
+       (with-connection conn
+         (continuously (dispatch-event (mb/receive (current-thread)) conn))))))